This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
24ae7bbdebd3847122f28479a82ed30b5c00d865
[perl5.git] / pp_hot.c
1 /*    pp_hot.c
2  *
3  *    Copyright (c) 1991-2001, 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 #define PERL_IN_PP_HOT_C
20 #include "perl.h"
21
22 /* Hot code. */
23
24 #ifdef USE_THREADS
25 static void unset_cvowner(pTHXo_ void *cvarg);
26 #endif /* USE_THREADS */
27
28 PP(pp_const)
29 {
30     djSP;
31     XPUSHs(cSVOP_sv);
32     RETURN;
33 }
34
35 PP(pp_nextstate)
36 {
37     PL_curcop = (COP*)PL_op;
38     TAINT_NOT;          /* Each statement is presumed innocent */
39     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
40     FREETMPS;
41     return NORMAL;
42 }
43
44 PP(pp_gvsv)
45 {
46     djSP;
47     EXTEND(SP,1);
48     if (PL_op->op_private & OPpLVAL_INTRO)
49         PUSHs(save_scalar(cGVOP_gv));
50     else
51         PUSHs(GvSV(cGVOP_gv));
52     RETURN;
53 }
54
55 PP(pp_null)
56 {
57     return NORMAL;
58 }
59
60 PP(pp_setstate)
61 {
62     PL_curcop = (COP*)PL_op;
63     return NORMAL;
64 }
65
66 PP(pp_pushmark)
67 {
68     PUSHMARK(PL_stack_sp);
69     return NORMAL;
70 }
71
72 PP(pp_stringify)
73 {
74     djSP; dTARGET;
75     STRLEN len;
76     char *s;
77     s = SvPV(TOPs,len);
78     sv_setpvn(TARG,s,len);
79     if (SvUTF8(TOPs) && !IN_BYTE)
80         SvUTF8_on(TARG);
81     else
82         SvUTF8_off(TARG);
83     SETTARG;
84     RETURN;
85 }
86
87 PP(pp_gv)
88 {
89     djSP;
90     XPUSHs((SV*)cGVOP_gv);
91     RETURN;
92 }
93
94 PP(pp_and)
95 {
96     djSP;
97     if (!SvTRUE(TOPs))
98         RETURN;
99     else {
100         --SP;
101         RETURNOP(cLOGOP->op_other);
102     }
103 }
104
105 PP(pp_sassign)
106 {
107     djSP; dPOPTOPssrl;
108
109     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
110         SV *temp;
111         temp = left; left = right; right = temp;
112     }
113     if (PL_tainting && PL_tainted && !SvTAINTED(left))
114         TAINT_NOT;
115     SvSetMagicSV(right, left);
116     SETs(right);
117     RETURN;
118 }
119
120 PP(pp_cond_expr)
121 {
122     djSP;
123     if (SvTRUEx(POPs))
124         RETURNOP(cLOGOP->op_other);
125     else
126         RETURNOP(cLOGOP->op_next);
127 }
128
129 PP(pp_unstack)
130 {
131     I32 oldsave;
132     TAINT_NOT;          /* Each statement is presumed innocent */
133     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
134     FREETMPS;
135     oldsave = PL_scopestack[PL_scopestack_ix - 1];
136     LEAVE_SCOPE(oldsave);
137     return NORMAL;
138 }
139
140 PP(pp_concat)
141 {
142   djSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
143   {
144     dPOPTOPssrl;
145     STRLEN len, llen, rlen;
146     U8 *s, *l, *r;
147     bool left_utf8;
148     bool right_utf8;
149
150     r = (U8*)SvPV(right,rlen);
151
152     if (TARG != left)
153         l = (U8*)SvPV(left,llen);
154     else if (SvGMAGICAL(left))
155         mg_get(left);
156
157     left_utf8  = DO_UTF8(left);
158     right_utf8 = DO_UTF8(right);
159
160     if (!left_utf8 && !right_utf8 && SvUTF8(TARG)) {
161         SvUTF8_off(TARG);
162     }
163
164     if (left_utf8 != right_utf8 && !IN_BYTE) {
165         if (TARG == right && !right_utf8) {
166             sv_utf8_upgrade(TARG); /* Now straight binary copy */
167             SvUTF8_on(TARG);
168         }
169         else {
170             /* Set TARG to PV(left), then add right */
171             U8 *c, *olds = NULL;
172             STRLEN targlen;
173             s = r; len = rlen;
174             if (TARG == right) {
175                 /* Take a copy since we're about to overwrite TARG */
176                 olds = s = (U8*)savepvn((char*)s, len);
177             }
178             if (!SvOK(left) && SvTYPE(left) <= SVt_PVMG) {
179                 if (SvREADONLY(left))
180                     left = sv_2mortal(newSVsv(left));
181                 else
182                     sv_setpv(left, ""); /* Suppress warning. */
183             }
184             if (TARG != left)
185                 sv_setpvn(TARG, (char*)l, llen);
186             if (!left_utf8) {
187                 SvUTF8_off(TARG);
188                 sv_utf8_upgrade(TARG);
189             }
190             /* Extend TARG to length of right (s) */
191             targlen = SvCUR(TARG) + len;
192             if (!right_utf8) {
193                 /* plus one for each hi-byte char if we have to upgrade */
194                 for (c = s; c < s + len; c++)  {
195                     if (UTF8_IS_CONTINUED(*c))
196                         targlen++;
197                 }
198             }
199             SvGROW(TARG, targlen+1);
200             /* And now copy, maybe upgrading right to UTF8 on the fly */
201             if (right_utf8)
202                 Copy(s, SvEND(TARG), len, U8);
203             else {
204                 for (c = (U8*)SvEND(TARG); len--; s++)
205                     c = uv_to_utf8(c, *s);
206             }
207             SvCUR_set(TARG, targlen);
208             *SvEND(TARG) = '\0';
209             SvUTF8_on(TARG);
210             SETs(TARG);
211             Safefree(olds);
212             RETURN;
213         }
214     }
215
216     if (TARG != left) {
217         if (TARG == right) {
218             sv_insert(TARG, 0, 0, (char*)l, llen);
219             SETs(TARG);
220             RETURN;
221         }
222         sv_setpvn(TARG, (char *)l, llen);
223     }
224     else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG)
225         sv_setpv(TARG, "");     /* Suppress warning. */
226     s = r; len = rlen;
227     if (SvOK(TARG)) {
228 #if defined(PERL_Y2KWARN)
229         if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K)) {
230             STRLEN n;
231             char *s = SvPV(TARG,n);
232             if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
233                 && (n == 2 || !isDIGIT(s[n-3])))
234             {
235                 Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s",
236                             "about to append an integer to '19'");
237             }
238         }
239 #endif
240         sv_catpvn(TARG, (char *)s, len);
241     }
242     else
243         sv_setpvn(TARG, (char *)s, len);        /* suppress warning */
244     if (left_utf8 && !IN_BYTE)
245         SvUTF8_on(TARG);
246     SETTARG;
247     RETURN;
248   }
249 }
250
251 PP(pp_padsv)
252 {
253     djSP; dTARGET;
254     XPUSHs(TARG);
255     if (PL_op->op_flags & OPf_MOD) {
256         if (PL_op->op_private & OPpLVAL_INTRO)
257             SAVECLEARSV(PL_curpad[PL_op->op_targ]);
258         else if (PL_op->op_private & OPpDEREF) {
259             PUTBACK;
260             vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
261             SPAGAIN;
262         }
263     }
264     RETURN;
265 }
266
267 PP(pp_readline)
268 {
269     tryAMAGICunTARGET(iter, 0);
270     PL_last_in_gv = (GV*)(*PL_stack_sp--);
271     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
272         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
273             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
274         else {
275             dSP;
276             XPUSHs((SV*)PL_last_in_gv);
277             PUTBACK;
278             pp_rv2gv();
279             PL_last_in_gv = (GV*)(*PL_stack_sp--);
280         }
281     }
282     return do_readline();
283 }
284
285 PP(pp_eq)
286 {
287     djSP; tryAMAGICbinSET(eq,0);
288 #ifdef PERL_PRESERVE_IVUV
289     SvIV_please(TOPs);
290     if (SvIOK(TOPs)) {
291         /* Unless the left argument is integer in range we are going to have to
292            use NV maths. Hence only attempt to coerce the right argument if
293            we know the left is integer.  */
294       SvIV_please(TOPm1s);
295         if (SvIOK(TOPm1s)) {
296             bool auvok = SvUOK(TOPm1s);
297             bool buvok = SvUOK(TOPs);
298         
299             if (!auvok && !buvok) { /* ## IV == IV ## */
300                 IV aiv = SvIVX(TOPm1s);
301                 IV biv = SvIVX(TOPs);
302                 
303                 SP--;
304                 SETs(boolSV(aiv == biv));
305                 RETURN;
306             }
307             if (auvok && buvok) { /* ## UV == UV ## */
308                 UV auv = SvUVX(TOPm1s);
309                 UV buv = SvUVX(TOPs);
310                 
311                 SP--;
312                 SETs(boolSV(auv == buv));
313                 RETURN;
314             }
315             {                   /* ## Mixed IV,UV ## */
316                 IV iv;
317                 UV uv;
318                 
319                 /* == is commutative so swap if needed (save code) */
320                 if (auvok) {
321                     /* swap. top of stack (b) is the iv */
322                     iv = SvIVX(TOPs);
323                     SP--;
324                     if (iv < 0) {
325                         /* As (a) is a UV, it's >0, so it cannot be == */
326                         SETs(&PL_sv_no);
327                         RETURN;
328                     }
329                     uv = SvUVX(TOPs);
330                 } else {
331                     iv = SvIVX(TOPm1s);
332                     SP--;
333                     if (iv < 0) {
334                         /* As (b) is a UV, it's >0, so it cannot be == */
335                         SETs(&PL_sv_no);
336                         RETURN;
337                     }
338                     uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
339                 }
340                 /* we know iv is >= 0 */
341                 if (uv > (UV) IV_MAX) {
342                     SETs(&PL_sv_no);
343                     RETURN;
344                 }
345                 SETs(boolSV((UV)iv == uv));
346                 RETURN;
347             }
348         }
349     }
350 #endif
351     {
352       dPOPnv;
353       SETs(boolSV(TOPn == value));
354       RETURN;
355     }
356 }
357
358 PP(pp_preinc)
359 {
360     djSP;
361     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
362         DIE(aTHX_ PL_no_modify);
363     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
364         SvIVX(TOPs) != IV_MAX)
365     {
366         ++SvIVX(TOPs);
367         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
368     }
369     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
370         sv_inc(TOPs);
371     SvSETMAGIC(TOPs);
372     return NORMAL;
373 }
374
375 PP(pp_or)
376 {
377     djSP;
378     if (SvTRUE(TOPs))
379         RETURN;
380     else {
381         --SP;
382         RETURNOP(cLOGOP->op_other);
383     }
384 }
385
386 PP(pp_add)
387 {
388     djSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
389     useleft = USE_LEFT(TOPm1s);
390 #ifdef PERL_PRESERVE_IVUV
391     /* We must see if we can perform the addition with integers if possible,
392        as the integer code detects overflow while the NV code doesn't.
393        If either argument hasn't had a numeric conversion yet attempt to get
394        the IV. It's important to do this now, rather than just assuming that
395        it's not IOK as a PV of "9223372036854775806" may not take well to NV
396        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
397        integer in case the second argument is IV=9223372036854775806
398        We can (now) rely on sv_2iv to do the right thing, only setting the
399        public IOK flag if the value in the NV (or PV) slot is truly integer.
400
401        A side effect is that this also aggressively prefers integer maths over
402        fp maths for integer values.  */
403     SvIV_please(TOPs);
404     if (SvIOK(TOPs)) {
405         /* Unless the left argument is integer in range we are going to have to
406            use NV maths. Hence only attempt to coerce the right argument if
407            we know the left is integer.  */
408         if (!useleft) {
409             /* left operand is undef, treat as zero. + 0 is identity. */
410             if (SvUOK(TOPs)) {
411                 dPOPuv; /* Scary macros. Lets put a sequence point (;) here */
412                 SETu(value);
413                 RETURN;
414             } else {
415                 dPOPiv;
416                 SETi(value);
417                 RETURN;
418             }
419         }
420         /* Left operand is defined, so is it IV? */
421         SvIV_please(TOPm1s);
422         if (SvIOK(TOPm1s)) {
423             bool auvok = SvUOK(TOPm1s);
424             bool buvok = SvUOK(TOPs);
425         
426             if (!auvok && !buvok) { /* ## IV + IV ## */
427                 IV aiv = SvIVX(TOPm1s);
428                 IV biv = SvIVX(TOPs);
429                 IV result = aiv + biv;
430                 
431                 if (biv >= 0 ? (result >= aiv) : (result < aiv)) {
432                     SP--;
433                     SETi( result );
434                     RETURN;
435                 }
436                 if (biv >=0 && aiv >= 0) {
437                     UV result = (UV)aiv + (UV)biv;
438                     /* UV + UV can only get bigger... */
439                     if (result >= (UV) aiv) {
440                         SP--;
441                         SETu( result );
442                         RETURN;
443                     }
444                 }
445                 /* Overflow, drop through to NVs (beyond next if () else ) */
446             } else if (auvok && buvok) {        /* ## UV + UV ## */
447                 UV auv = SvUVX(TOPm1s);
448                 UV buv = SvUVX(TOPs);
449                 UV result = auv + buv;
450                 if (result >= auv) {
451                     SP--;
452                     SETu( result );
453                     RETURN;
454                 }
455                 /* Overflow, drop through to NVs (beyond next if () else ) */
456             } else {                    /* ## Mixed IV,UV ## */
457                 IV aiv;
458                 UV buv;
459                 
460                 /* addition is commutative so swap if needed (save code) */
461                 if (buvok) {
462                     aiv = SvIVX(TOPm1s);
463                     buv = SvUVX(TOPs);
464                 } else {
465                     aiv = SvIVX(TOPs);
466                     buv = SvUVX(TOPm1s);
467                 }
468         
469                 if (aiv >= 0) {
470                     UV result = (UV)aiv + buv;
471                     if (result >= buv) {
472                         SP--;
473                         SETu( result );
474                         RETURN;
475                     }
476                 } else if (buv > (UV) IV_MAX) {
477                     /* assuming 2s complement means that IV_MIN == -IV_MIN,
478                        and (UV)-IV_MIN *is* the value -IV_MIN (or IV_MAX + 1)
479                        as buv > IV_MAX, it is >= (IV_MAX + 1), and therefore
480                        as the value we can be subtracting from it only lies in
481                        the range (-IV_MIN to -1) it can't overflow a UV */
482                     SP--;
483                     SETu( buv - (UV)-aiv );
484                     RETURN;
485                 } else {
486                     IV result = (IV) buv + aiv;
487                     /* aiv < 0 so it must get smaller.  */
488                     if (result < (IV) buv) {
489                         SP--;
490                         SETi( result );
491                         RETURN;
492                     }
493                 }
494             } /* end of IV+IV / UV+UV / mixed */
495         }
496     }
497 #endif
498     {
499         dPOPnv;
500         if (!useleft) {
501             /* left operand is undef, treat as zero. + 0.0 is identity. */
502             SETn(value);
503             RETURN;
504         }
505         SETn( value + TOPn );
506         RETURN;
507     }
508 }
509
510 PP(pp_aelemfast)
511 {
512     djSP;
513     AV *av = GvAV(cGVOP_gv);
514     U32 lval = PL_op->op_flags & OPf_MOD;
515     SV** svp = av_fetch(av, PL_op->op_private, lval);
516     SV *sv = (svp ? *svp : &PL_sv_undef);
517     EXTEND(SP, 1);
518     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
519         sv = sv_mortalcopy(sv);
520     PUSHs(sv);
521     RETURN;
522 }
523
524 PP(pp_join)
525 {
526     djSP; dMARK; dTARGET;
527     MARK++;
528     do_join(TARG, *MARK, MARK, SP);
529     SP = MARK;
530     SETs(TARG);
531     RETURN;
532 }
533
534 PP(pp_pushre)
535 {
536     djSP;
537 #ifdef DEBUGGING
538     /*
539      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
540      * will be enough to hold an OP*.
541      */
542     SV* sv = sv_newmortal();
543     sv_upgrade(sv, SVt_PVLV);
544     LvTYPE(sv) = '/';
545     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
546     XPUSHs(sv);
547 #else
548     XPUSHs((SV*)PL_op);
549 #endif
550     RETURN;
551 }
552
553 /* Oversized hot code. */
554
555 PP(pp_print)
556 {
557     djSP; dMARK; dORIGMARK;
558     GV *gv;
559     IO *io;
560     register PerlIO *fp;
561     MAGIC *mg;
562     STRLEN n_a;
563
564     if (PL_op->op_flags & OPf_STACKED)
565         gv = (GV*)*++MARK;
566     else
567         gv = PL_defoutgv;
568     if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
569       had_magic:
570         if (MARK == ORIGMARK) {
571             /* If using default handle then we need to make space to
572              * pass object as 1st arg, so move other args up ...
573              */
574             MEXTEND(SP, 1);
575             ++MARK;
576             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
577             ++SP;
578         }
579         PUSHMARK(MARK - 1);
580         *MARK = SvTIED_obj((SV*)gv, mg);
581         PUTBACK;
582         ENTER;
583         call_method("PRINT", G_SCALAR);
584         LEAVE;
585         SPAGAIN;
586         MARK = ORIGMARK + 1;
587         *MARK = *SP;
588         SP = MARK;
589         RETURN;
590     }
591     if (!(io = GvIO(gv))) {
592         if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
593             goto had_magic;
594         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
595             report_evil_fh(gv, io, PL_op->op_type);
596         SETERRNO(EBADF,RMS$_IFI);
597         goto just_say_no;
598     }
599     else if (!(fp = IoOFP(io))) {
600         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
601             if (IoIFP(io))
602                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
603             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
604                 report_evil_fh(gv, io, PL_op->op_type);
605         }
606         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
607         goto just_say_no;
608     }
609     else {
610         MARK++;
611         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
612             while (MARK <= SP) {
613                 if (!do_print(*MARK, fp))
614                     break;
615                 MARK++;
616                 if (MARK <= SP) {
617                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
618                         MARK--;
619                         break;
620                     }
621                 }
622             }
623         }
624         else {
625             while (MARK <= SP) {
626                 if (!do_print(*MARK, fp))
627                     break;
628                 MARK++;
629             }
630         }
631         if (MARK <= SP)
632             goto just_say_no;
633         else {
634             if (PL_ors_sv && SvOK(PL_ors_sv))
635                 if (!do_print(PL_ors_sv, fp)) /* $\ */
636                     goto just_say_no;
637
638             if (IoFLAGS(io) & IOf_FLUSH)
639                 if (PerlIO_flush(fp) == EOF)
640                     goto just_say_no;
641         }
642     }
643     SP = ORIGMARK;
644     PUSHs(&PL_sv_yes);
645     RETURN;
646
647   just_say_no:
648     SP = ORIGMARK;
649     PUSHs(&PL_sv_undef);
650     RETURN;
651 }
652
653 PP(pp_rv2av)
654 {
655     djSP; dTOPss;
656     AV *av;
657
658     if (SvROK(sv)) {
659       wasref:
660         tryAMAGICunDEREF(to_av);
661
662         av = (AV*)SvRV(sv);
663         if (SvTYPE(av) != SVt_PVAV)
664             DIE(aTHX_ "Not an ARRAY reference");
665         if (PL_op->op_flags & OPf_REF) {
666             SETs((SV*)av);
667             RETURN;
668         }
669     }
670     else {
671         if (SvTYPE(sv) == SVt_PVAV) {
672             av = (AV*)sv;
673             if (PL_op->op_flags & OPf_REF) {
674                 SETs((SV*)av);
675                 RETURN;
676             }
677         }
678         else {
679             GV *gv;
680         
681             if (SvTYPE(sv) != SVt_PVGV) {
682                 char *sym;
683                 STRLEN len;
684
685                 if (SvGMAGICAL(sv)) {
686                     mg_get(sv);
687                     if (SvROK(sv))
688                         goto wasref;
689                 }
690                 if (!SvOK(sv)) {
691                     if (PL_op->op_flags & OPf_REF ||
692                       PL_op->op_private & HINT_STRICT_REFS)
693                         DIE(aTHX_ PL_no_usym, "an ARRAY");
694                     if (ckWARN(WARN_UNINITIALIZED))
695                         report_uninit();
696                     if (GIMME == G_ARRAY) {
697                         (void)POPs;
698                         RETURN;
699                     }
700                     RETSETUNDEF;
701                 }
702                 sym = SvPV(sv,len);
703                 if ((PL_op->op_flags & OPf_SPECIAL) &&
704                     !(PL_op->op_flags & OPf_MOD))
705                 {
706                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
707                     if (!gv
708                         && (!is_gv_magical(sym,len,0)
709                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
710                     {
711                         RETSETUNDEF;
712                     }
713                 }
714                 else {
715                     if (PL_op->op_private & HINT_STRICT_REFS)
716                         DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
717                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
718                 }
719             }
720             else {
721                 gv = (GV*)sv;
722             }
723             av = GvAVn(gv);
724             if (PL_op->op_private & OPpLVAL_INTRO)
725                 av = save_ary(gv);
726             if (PL_op->op_flags & OPf_REF) {
727                 SETs((SV*)av);
728                 RETURN;
729             }
730         }
731     }
732
733     if (GIMME == G_ARRAY) {
734         I32 maxarg = AvFILL(av) + 1;
735         (void)POPs;                     /* XXXX May be optimized away? */
736         EXTEND(SP, maxarg);
737         if (SvRMAGICAL(av)) {
738             U32 i;
739             for (i=0; i < maxarg; i++) {
740                 SV **svp = av_fetch(av, i, FALSE);
741                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
742             }
743         }
744         else {
745             Copy(AvARRAY(av), SP+1, maxarg, SV*);
746         }
747         SP += maxarg;
748     }
749     else {
750         dTARGET;
751         I32 maxarg = AvFILL(av) + 1;
752         SETi(maxarg);
753     }
754     RETURN;
755 }
756
757 PP(pp_rv2hv)
758 {
759     djSP; dTOPss;
760     HV *hv;
761
762     if (SvROK(sv)) {
763       wasref:
764         tryAMAGICunDEREF(to_hv);
765
766         hv = (HV*)SvRV(sv);
767         if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
768             DIE(aTHX_ "Not a HASH reference");
769         if (PL_op->op_flags & OPf_REF) {
770             SETs((SV*)hv);
771             RETURN;
772         }
773     }
774     else {
775         if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
776             hv = (HV*)sv;
777             if (PL_op->op_flags & OPf_REF) {
778                 SETs((SV*)hv);
779                 RETURN;
780             }
781         }
782         else {
783             GV *gv;
784         
785             if (SvTYPE(sv) != SVt_PVGV) {
786                 char *sym;
787                 STRLEN len;
788
789                 if (SvGMAGICAL(sv)) {
790                     mg_get(sv);
791                     if (SvROK(sv))
792                         goto wasref;
793                 }
794                 if (!SvOK(sv)) {
795                     if (PL_op->op_flags & OPf_REF ||
796                       PL_op->op_private & HINT_STRICT_REFS)
797                         DIE(aTHX_ PL_no_usym, "a HASH");
798                     if (ckWARN(WARN_UNINITIALIZED))
799                         report_uninit();
800                     if (GIMME == G_ARRAY) {
801                         SP--;
802                         RETURN;
803                     }
804                     RETSETUNDEF;
805                 }
806                 sym = SvPV(sv,len);
807                 if ((PL_op->op_flags & OPf_SPECIAL) &&
808                     !(PL_op->op_flags & OPf_MOD))
809                 {
810                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
811                     if (!gv
812                         && (!is_gv_magical(sym,len,0)
813                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
814                     {
815                         RETSETUNDEF;
816                     }
817                 }
818                 else {
819                     if (PL_op->op_private & HINT_STRICT_REFS)
820                         DIE(aTHX_ PL_no_symref, sym, "a HASH");
821                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
822                 }
823             }
824             else {
825                 gv = (GV*)sv;
826             }
827             hv = GvHVn(gv);
828             if (PL_op->op_private & OPpLVAL_INTRO)
829                 hv = save_hash(gv);
830             if (PL_op->op_flags & OPf_REF) {
831                 SETs((SV*)hv);
832                 RETURN;
833             }
834         }
835     }
836
837     if (GIMME == G_ARRAY) { /* array wanted */
838         *PL_stack_sp = (SV*)hv;
839         return do_kv();
840     }
841     else {
842         dTARGET;
843         if (SvTYPE(hv) == SVt_PVAV)
844             hv = avhv_keys((AV*)hv);
845         if (HvFILL(hv))
846             Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
847                            (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
848         else
849             sv_setiv(TARG, 0);
850         
851         SETTARG;
852         RETURN;
853     }
854 }
855
856 STATIC int
857 S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem,
858                  SV **lastrelem)
859 {
860     OP *leftop;
861     I32 i;
862
863     leftop = ((BINOP*)PL_op)->op_last;
864     assert(leftop);
865     assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST);
866     leftop = ((LISTOP*)leftop)->op_first;
867     assert(leftop);
868     /* Skip PUSHMARK and each element already assigned to. */
869     for (i = lelem - firstlelem; i > 0; i--) {
870         leftop = leftop->op_sibling;
871         assert(leftop);
872     }
873     if (leftop->op_type != OP_RV2HV)
874         return 0;
875
876     /* pseudohash */
877     if (av_len(ary) > 0)
878         av_fill(ary, 0);                /* clear all but the fields hash */
879     if (lastrelem >= relem) {
880         while (relem < lastrelem) {     /* gobble up all the rest */
881             SV *tmpstr;
882             assert(relem[0]);
883             assert(relem[1]);
884             /* Avoid a memory leak when avhv_store_ent dies. */
885             tmpstr = sv_newmortal();
886             sv_setsv(tmpstr,relem[1]);  /* value */
887             relem[1] = tmpstr;
888             if (avhv_store_ent(ary,relem[0],tmpstr,0))
889                 (void)SvREFCNT_inc(tmpstr);
890             if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr))
891                 mg_set(tmpstr);
892             relem += 2;
893             TAINT_NOT;
894         }
895     }
896     if (relem == lastrelem)
897         return 1;
898     return 2;
899 }
900
901 STATIC void
902 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
903 {
904     if (*relem) {
905         SV *tmpstr;
906         if (ckWARN(WARN_MISC)) {
907             if (relem == firstrelem &&
908                 SvROK(*relem) &&
909                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
910                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
911             {
912                 Perl_warner(aTHX_ WARN_MISC,
913                             "Reference found where even-sized list expected");
914             }
915             else
916                 Perl_warner(aTHX_ WARN_MISC,
917                             "Odd number of elements in hash assignment");
918         }
919         if (SvTYPE(hash) == SVt_PVAV) {
920             /* pseudohash */
921             tmpstr = sv_newmortal();
922             if (avhv_store_ent((AV*)hash,*relem,tmpstr,0))
923                 (void)SvREFCNT_inc(tmpstr);
924             if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr))
925                 mg_set(tmpstr);
926         }
927         else {
928             HE *didstore;
929             tmpstr = NEWSV(29,0);
930             didstore = hv_store_ent(hash,*relem,tmpstr,0);
931             if (SvMAGICAL(hash)) {
932                 if (SvSMAGICAL(tmpstr))
933                     mg_set(tmpstr);
934                 if (!didstore)
935                     sv_2mortal(tmpstr);
936             }
937         }
938         TAINT_NOT;
939     }
940 }
941
942 PP(pp_aassign)
943 {
944     djSP;
945     SV **lastlelem = PL_stack_sp;
946     SV **lastrelem = PL_stack_base + POPMARK;
947     SV **firstrelem = PL_stack_base + POPMARK + 1;
948     SV **firstlelem = lastrelem + 1;
949
950     register SV **relem;
951     register SV **lelem;
952
953     register SV *sv;
954     register AV *ary;
955
956     I32 gimme;
957     HV *hash;
958     I32 i;
959     int magic;
960
961     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
962
963     /* If there's a common identifier on both sides we have to take
964      * special care that assigning the identifier on the left doesn't
965      * clobber a value on the right that's used later in the list.
966      */
967     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
968         EXTEND_MORTAL(lastrelem - firstrelem + 1);
969         for (relem = firstrelem; relem <= lastrelem; relem++) {
970             /*SUPPRESS 560*/
971             if ((sv = *relem)) {
972                 TAINT_NOT;      /* Each item is independent */
973                 *relem = sv_mortalcopy(sv);
974             }
975         }
976     }
977
978     relem = firstrelem;
979     lelem = firstlelem;
980     ary = Null(AV*);
981     hash = Null(HV*);
982
983     while (lelem <= lastlelem) {
984         TAINT_NOT;              /* Each item stands on its own, taintwise. */
985         sv = *lelem++;
986         switch (SvTYPE(sv)) {
987         case SVt_PVAV:
988             ary = (AV*)sv;
989             magic = SvMAGICAL(ary) != 0;
990             if (PL_op->op_private & OPpASSIGN_HASH) {
991                 switch (do_maybe_phash(ary, lelem, firstlelem, relem,
992                                        lastrelem))
993                 {
994                 case 0:
995                     goto normal_array;
996                 case 1:
997                     do_oddball((HV*)ary, relem, firstrelem);
998                 }
999                 relem = lastrelem + 1;
1000                 break;
1001             }
1002         normal_array:
1003             av_clear(ary);
1004             av_extend(ary, lastrelem - relem);
1005             i = 0;
1006             while (relem <= lastrelem) {        /* gobble up all the rest */
1007                 SV **didstore;
1008                 sv = NEWSV(28,0);
1009                 assert(*relem);
1010                 sv_setsv(sv,*relem);
1011                 *(relem++) = sv;
1012                 didstore = av_store(ary,i++,sv);
1013                 if (magic) {
1014                     if (SvSMAGICAL(sv))
1015                         mg_set(sv);
1016                     if (!didstore)
1017                         sv_2mortal(sv);
1018                 }
1019                 TAINT_NOT;
1020             }
1021             break;
1022         case SVt_PVHV: {                                /* normal hash */
1023                 SV *tmpstr;
1024
1025                 hash = (HV*)sv;
1026                 magic = SvMAGICAL(hash) != 0;
1027                 hv_clear(hash);
1028
1029                 while (relem < lastrelem) {     /* gobble up all the rest */
1030                     HE *didstore;
1031                     if (*relem)
1032                         sv = *(relem++);
1033                     else
1034                         sv = &PL_sv_no, relem++;
1035                     tmpstr = NEWSV(29,0);
1036                     if (*relem)
1037                         sv_setsv(tmpstr,*relem);        /* value */
1038                     *(relem++) = tmpstr;
1039                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1040                     if (magic) {
1041                         if (SvSMAGICAL(tmpstr))
1042                             mg_set(tmpstr);
1043                         if (!didstore)
1044                             sv_2mortal(tmpstr);
1045                     }
1046                     TAINT_NOT;
1047                 }
1048                 if (relem == lastrelem) {
1049                     do_oddball(hash, relem, firstrelem);
1050                     relem++;
1051                 }
1052             }
1053             break;
1054         default:
1055             if (SvIMMORTAL(sv)) {
1056                 if (relem <= lastrelem)
1057                     relem++;
1058                 break;
1059             }
1060             if (relem <= lastrelem) {
1061                 sv_setsv(sv, *relem);
1062                 *(relem++) = sv;
1063             }
1064             else
1065                 sv_setsv(sv, &PL_sv_undef);
1066             SvSETMAGIC(sv);
1067             break;
1068         }
1069     }
1070     if (PL_delaymagic & ~DM_DELAY) {
1071         if (PL_delaymagic & DM_UID) {
1072 #ifdef HAS_SETRESUID
1073             (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1074 #else
1075 #  ifdef HAS_SETREUID
1076             (void)setreuid(PL_uid,PL_euid);
1077 #  else
1078 #    ifdef HAS_SETRUID
1079             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1080                 (void)setruid(PL_uid);
1081                 PL_delaymagic &= ~DM_RUID;
1082             }
1083 #    endif /* HAS_SETRUID */
1084 #    ifdef HAS_SETEUID
1085             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1086                 (void)seteuid(PL_uid);
1087                 PL_delaymagic &= ~DM_EUID;
1088             }
1089 #    endif /* HAS_SETEUID */
1090             if (PL_delaymagic & DM_UID) {
1091                 if (PL_uid != PL_euid)
1092                     DIE(aTHX_ "No setreuid available");
1093                 (void)PerlProc_setuid(PL_uid);
1094             }
1095 #  endif /* HAS_SETREUID */
1096 #endif /* HAS_SETRESUID */
1097             PL_uid = PerlProc_getuid();
1098             PL_euid = PerlProc_geteuid();
1099         }
1100         if (PL_delaymagic & DM_GID) {
1101 #ifdef HAS_SETRESGID
1102             (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1103 #else
1104 #  ifdef HAS_SETREGID
1105             (void)setregid(PL_gid,PL_egid);
1106 #  else
1107 #    ifdef HAS_SETRGID
1108             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1109                 (void)setrgid(PL_gid);
1110                 PL_delaymagic &= ~DM_RGID;
1111             }
1112 #    endif /* HAS_SETRGID */
1113 #    ifdef HAS_SETEGID
1114             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1115                 (void)setegid(PL_gid);
1116                 PL_delaymagic &= ~DM_EGID;
1117             }
1118 #    endif /* HAS_SETEGID */
1119             if (PL_delaymagic & DM_GID) {
1120                 if (PL_gid != PL_egid)
1121                     DIE(aTHX_ "No setregid available");
1122                 (void)PerlProc_setgid(PL_gid);
1123             }
1124 #  endif /* HAS_SETREGID */
1125 #endif /* HAS_SETRESGID */
1126             PL_gid = PerlProc_getgid();
1127             PL_egid = PerlProc_getegid();
1128         }
1129         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1130     }
1131     PL_delaymagic = 0;
1132
1133     gimme = GIMME_V;
1134     if (gimme == G_VOID)
1135         SP = firstrelem - 1;
1136     else if (gimme == G_SCALAR) {
1137         dTARGET;
1138         SP = firstrelem;
1139         SETi(lastrelem - firstrelem + 1);
1140     }
1141     else {
1142         if (ary || hash)
1143             SP = lastrelem;
1144         else
1145             SP = firstrelem + (lastlelem - firstlelem);
1146         lelem = firstlelem + (relem - firstrelem);
1147         while (relem <= SP)
1148             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1149     }
1150     RETURN;
1151 }
1152
1153 PP(pp_qr)
1154 {
1155     djSP;
1156     register PMOP *pm = cPMOP;
1157     SV *rv = sv_newmortal();
1158     SV *sv = newSVrv(rv, "Regexp");
1159     sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp),'r',0,0);
1160     RETURNX(PUSHs(rv));
1161 }
1162
1163 PP(pp_match)
1164 {
1165     djSP; dTARG;
1166     register PMOP *pm = cPMOP;
1167     register char *t;
1168     register char *s;
1169     char *strend;
1170     I32 global;
1171     I32 r_flags = REXEC_CHECKED;
1172     char *truebase;                     /* Start of string  */
1173     register REGEXP *rx = pm->op_pmregexp;
1174     bool rxtainted;
1175     I32 gimme = GIMME;
1176     STRLEN len;
1177     I32 minmatch = 0;
1178     I32 oldsave = PL_savestack_ix;
1179     I32 update_minmatch = 1;
1180     I32 had_zerolen = 0;
1181
1182     if (PL_op->op_flags & OPf_STACKED)
1183         TARG = POPs;
1184     else {
1185         TARG = DEFSV;
1186         EXTEND(SP,1);
1187     }
1188     PL_reg_sv = TARG;
1189     PUTBACK;                            /* EVAL blocks need stack_sp. */
1190     s = SvPV(TARG, len);
1191     strend = s + len;
1192     if (!s)
1193         DIE(aTHX_ "panic: pp_match");
1194     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1195                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1196     TAINT_NOT;
1197
1198     if (pm->op_pmdynflags & PMdf_USED) {
1199       failure:
1200         if (gimme == G_ARRAY)
1201             RETURN;
1202         RETPUSHNO;
1203     }
1204
1205     if (!rx->prelen && PL_curpm) {
1206         pm = PL_curpm;
1207         rx = pm->op_pmregexp;
1208     }
1209     if (rx->minlen > len) goto failure;
1210
1211     truebase = t = s;
1212
1213     /* XXXX What part of this is needed with true \G-support? */
1214     if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1215         rx->startp[0] = -1;
1216         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1217             MAGIC* mg = mg_find(TARG, 'g');
1218             if (mg && mg->mg_len >= 0) {
1219                 if (!(rx->reganch & ROPT_GPOS_SEEN))
1220                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1221                 else if (rx->reganch & ROPT_ANCH_GPOS) {
1222                     r_flags |= REXEC_IGNOREPOS;
1223                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1224                 }
1225                 minmatch = (mg->mg_flags & MGf_MINMATCH);
1226                 update_minmatch = 0;
1227             }
1228         }
1229     }
1230     if ((gimme != G_ARRAY && !global && rx->nparens)
1231             || SvTEMP(TARG) || PL_sawampersand)
1232         r_flags |= REXEC_COPY_STR;
1233     if (SvSCREAM(TARG))
1234         r_flags |= REXEC_SCREAM;
1235
1236     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1237         SAVEINT(PL_multiline);
1238         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1239     }
1240
1241 play_it_again:
1242     if (global && rx->startp[0] != -1) {
1243         t = s = rx->endp[0] + truebase;
1244         if ((s + rx->minlen) > strend)
1245             goto nope;
1246         if (update_minmatch++)
1247             minmatch = had_zerolen;
1248     }
1249     if (rx->reganch & RE_USE_INTUIT &&
1250         DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1251         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1252
1253         if (!s)
1254             goto nope;
1255         if ( (rx->reganch & ROPT_CHECK_ALL)
1256              && !PL_sawampersand
1257              && ((rx->reganch & ROPT_NOSCAN)
1258                  || !((rx->reganch & RE_INTUIT_TAIL)
1259                       && (r_flags & REXEC_SCREAM)))
1260              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1261             goto yup;
1262     }
1263     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1264     {
1265         PL_curpm = pm;
1266         if (pm->op_pmflags & PMf_ONCE)
1267             pm->op_pmdynflags |= PMdf_USED;
1268         goto gotcha;
1269     }
1270     else
1271         goto ret_no;
1272     /*NOTREACHED*/
1273
1274   gotcha:
1275     if (rxtainted)
1276         RX_MATCH_TAINTED_on(rx);
1277     TAINT_IF(RX_MATCH_TAINTED(rx));
1278     if (gimme == G_ARRAY) {
1279         I32 nparens, i, len;
1280
1281         nparens = rx->nparens;
1282         if (global && !nparens)
1283             i = 1;
1284         else
1285             i = 0;
1286         SPAGAIN;                        /* EVAL blocks could move the stack. */
1287         EXTEND(SP, nparens + i);
1288         EXTEND_MORTAL(nparens + i);
1289         for (i = !i; i <= nparens; i++) {
1290             PUSHs(sv_newmortal());
1291             /*SUPPRESS 560*/
1292             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1293                 len = rx->endp[i] - rx->startp[i];
1294                 s = rx->startp[i] + truebase;
1295                 sv_setpvn(*SP, s, len);
1296                 if (DO_UTF8(TARG))
1297                     SvUTF8_on(*SP);
1298             }
1299         }
1300         if (global) {
1301             had_zerolen = (rx->startp[0] != -1
1302                            && rx->startp[0] == rx->endp[0]);
1303             PUTBACK;                    /* EVAL blocks may use stack */
1304             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1305             goto play_it_again;
1306         }
1307         else if (!nparens)
1308             XPUSHs(&PL_sv_yes);
1309         LEAVE_SCOPE(oldsave);
1310         RETURN;
1311     }
1312     else {
1313         if (global) {
1314             MAGIC* mg = 0;
1315             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1316                 mg = mg_find(TARG, 'g');
1317             if (!mg) {
1318                 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
1319                 mg = mg_find(TARG, 'g');
1320             }
1321             if (rx->startp[0] != -1) {
1322                 mg->mg_len = rx->endp[0];
1323                 if (rx->startp[0] == rx->endp[0])
1324                     mg->mg_flags |= MGf_MINMATCH;
1325                 else
1326                     mg->mg_flags &= ~MGf_MINMATCH;
1327             }
1328         }
1329         LEAVE_SCOPE(oldsave);
1330         RETPUSHYES;
1331     }
1332
1333 yup:                                    /* Confirmed by INTUIT */
1334     if (rxtainted)
1335         RX_MATCH_TAINTED_on(rx);
1336     TAINT_IF(RX_MATCH_TAINTED(rx));
1337     PL_curpm = pm;
1338     if (pm->op_pmflags & PMf_ONCE)
1339         pm->op_pmdynflags |= PMdf_USED;
1340     if (RX_MATCH_COPIED(rx))
1341         Safefree(rx->subbeg);
1342     RX_MATCH_COPIED_off(rx);
1343     rx->subbeg = Nullch;
1344     if (global) {
1345         rx->subbeg = truebase;
1346         rx->startp[0] = s - truebase;
1347         if (DO_UTF8(PL_reg_sv)) {
1348             char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1349             rx->endp[0] = t - truebase;
1350         }
1351         else {
1352             rx->endp[0] = s - truebase + rx->minlen;
1353         }
1354         rx->sublen = strend - truebase;
1355         goto gotcha;
1356     }
1357     if (PL_sawampersand) {
1358         I32 off;
1359
1360         rx->subbeg = savepvn(t, strend - t);
1361         rx->sublen = strend - t;
1362         RX_MATCH_COPIED_on(rx);
1363         off = rx->startp[0] = s - t;
1364         rx->endp[0] = off + rx->minlen;
1365     }
1366     else {                      /* startp/endp are used by @- @+. */
1367         rx->startp[0] = s - truebase;
1368         rx->endp[0] = s - truebase + rx->minlen;
1369     }
1370     rx->nparens = rx->lastparen = 0;    /* used by @- and @+ */
1371     LEAVE_SCOPE(oldsave);
1372     RETPUSHYES;
1373
1374 nope:
1375 ret_no:
1376     if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1377         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1378             MAGIC* mg = mg_find(TARG, 'g');
1379             if (mg)
1380                 mg->mg_len = -1;
1381         }
1382     }
1383     LEAVE_SCOPE(oldsave);
1384     if (gimme == G_ARRAY)
1385         RETURN;
1386     RETPUSHNO;
1387 }
1388
1389 OP *
1390 Perl_do_readline(pTHX)
1391 {
1392     dSP; dTARGETSTACKED;
1393     register SV *sv;
1394     STRLEN tmplen = 0;
1395     STRLEN offset;
1396     PerlIO *fp;
1397     register IO *io = GvIO(PL_last_in_gv);
1398     register I32 type = PL_op->op_type;
1399     I32 gimme = GIMME_V;
1400     MAGIC *mg;
1401
1402     if ((mg = SvTIED_mg((SV*)PL_last_in_gv, 'q'))) {
1403         PUSHMARK(SP);
1404         XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg));
1405         PUTBACK;
1406         ENTER;
1407         call_method("READLINE", gimme);
1408         LEAVE;
1409         SPAGAIN;
1410         if (gimme == G_SCALAR)
1411             SvSetMagicSV_nosteal(TARG, TOPs);
1412         RETURN;
1413     }
1414     fp = Nullfp;
1415     if (io) {
1416         fp = IoIFP(io);
1417         if (!fp) {
1418             if (IoFLAGS(io) & IOf_ARGV) {
1419                 if (IoFLAGS(io) & IOf_START) {
1420                     IoLINES(io) = 0;
1421                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1422                         IoFLAGS(io) &= ~IOf_START;
1423                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1424                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1425                         SvSETMAGIC(GvSV(PL_last_in_gv));
1426                         fp = IoIFP(io);
1427                         goto have_fp;
1428                     }
1429                 }
1430                 fp = nextargv(PL_last_in_gv);
1431                 if (!fp) { /* Note: fp != IoIFP(io) */
1432                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1433                 }
1434             }
1435             else if (type == OP_GLOB)
1436                 fp = Perl_start_glob(aTHX_ POPs, io);
1437         }
1438         else if (type == OP_GLOB)
1439             SP--;
1440         else if (ckWARN(WARN_IO)        /* stdout/stderr or other write fh */
1441                  && (IoTYPE(io) == IoTYPE_WRONLY || fp == PerlIO_stdout()
1442                      || fp == PerlIO_stderr()))
1443             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1444     }
1445     if (!fp) {
1446         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1447                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1448             if (type == OP_GLOB)
1449                 Perl_warner(aTHX_ WARN_GLOB,
1450                             "glob failed (can't start child: %s)",
1451                             Strerror(errno));
1452             else
1453                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1454         }
1455         if (gimme == G_SCALAR) {
1456             (void)SvOK_off(TARG);
1457             PUSHTARG;
1458         }
1459         RETURN;
1460     }
1461   have_fp:
1462     if (gimme == G_SCALAR) {
1463         sv = TARG;
1464         if (SvROK(sv))
1465             sv_unref(sv);
1466         (void)SvUPGRADE(sv, SVt_PV);
1467         tmplen = SvLEN(sv);     /* remember if already alloced */
1468         if (!tmplen)
1469             Sv_Grow(sv, 80);    /* try short-buffering it */
1470         if (type == OP_RCATLINE)
1471             offset = SvCUR(sv);
1472         else
1473             offset = 0;
1474     }
1475     else {
1476         sv = sv_2mortal(NEWSV(57, 80));
1477         offset = 0;
1478     }
1479
1480     /* This should not be marked tainted if the fp is marked clean */
1481 #define MAYBE_TAINT_LINE(io, sv) \
1482     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1483         TAINT;                          \
1484         SvTAINTED_on(sv);               \
1485     }
1486
1487 /* delay EOF state for a snarfed empty file */
1488 #define SNARF_EOF(gimme,rs,io,sv) \
1489     (gimme != G_SCALAR || SvCUR(sv)                                     \
1490      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1491
1492     for (;;) {
1493         if (!sv_gets(sv, fp, offset)
1494             && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1495         {
1496             PerlIO_clearerr(fp);
1497             if (IoFLAGS(io) & IOf_ARGV) {
1498                 fp = nextargv(PL_last_in_gv);
1499                 if (fp)
1500                     continue;
1501                 (void)do_close(PL_last_in_gv, FALSE);
1502             }
1503             else if (type == OP_GLOB) {
1504                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1505                     Perl_warner(aTHX_ WARN_GLOB,
1506                            "glob failed (child exited with status %d%s)",
1507                            (int)(STATUS_CURRENT >> 8),
1508                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1509                 }
1510             }
1511             if (gimme == G_SCALAR) {
1512                 (void)SvOK_off(TARG);
1513                 PUSHTARG;
1514             }
1515             MAYBE_TAINT_LINE(io, sv);
1516             RETURN;
1517         }
1518         MAYBE_TAINT_LINE(io, sv);
1519         IoLINES(io)++;
1520         IoFLAGS(io) |= IOf_NOLINE;
1521         SvSETMAGIC(sv);
1522         XPUSHs(sv);
1523         if (type == OP_GLOB) {
1524             char *tmps;
1525
1526             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1527                 tmps = SvEND(sv) - 1;
1528                 if (*tmps == *SvPVX(PL_rs)) {
1529                     *tmps = '\0';
1530                     SvCUR(sv)--;
1531                 }
1532             }
1533             for (tmps = SvPVX(sv); *tmps; tmps++)
1534                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1535                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1536                         break;
1537             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1538                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1539                 continue;
1540             }
1541         }
1542         if (gimme == G_ARRAY) {
1543             if (SvLEN(sv) - SvCUR(sv) > 20) {
1544                 SvLEN_set(sv, SvCUR(sv)+1);
1545                 Renew(SvPVX(sv), SvLEN(sv), char);
1546             }
1547             sv = sv_2mortal(NEWSV(58, 80));
1548             continue;
1549         }
1550         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1551             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1552             if (SvCUR(sv) < 60)
1553                 SvLEN_set(sv, 80);
1554             else
1555                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1556             Renew(SvPVX(sv), SvLEN(sv), char);
1557         }
1558         RETURN;
1559     }
1560 }
1561
1562 PP(pp_enter)
1563 {
1564     djSP;
1565     register PERL_CONTEXT *cx;
1566     I32 gimme = OP_GIMME(PL_op, -1);
1567
1568     if (gimme == -1) {
1569         if (cxstack_ix >= 0)
1570             gimme = cxstack[cxstack_ix].blk_gimme;
1571         else
1572             gimme = G_SCALAR;
1573     }
1574
1575     ENTER;
1576
1577     SAVETMPS;
1578     PUSHBLOCK(cx, CXt_BLOCK, SP);
1579
1580     RETURN;
1581 }
1582
1583 PP(pp_helem)
1584 {
1585     djSP;
1586     HE* he;
1587     SV **svp;
1588     SV *keysv = POPs;
1589     HV *hv = (HV*)POPs;
1590     U32 lval = PL_op->op_flags & OPf_MOD;
1591     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1592     SV *sv;
1593     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1594     I32 preeminent;
1595
1596     if (SvTYPE(hv) == SVt_PVHV) {
1597         if (PL_op->op_private & OPpLVAL_INTRO)
1598             preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1599         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1600         svp = he ? &HeVAL(he) : 0;
1601     }
1602     else if (SvTYPE(hv) == SVt_PVAV) {
1603         if (PL_op->op_private & OPpLVAL_INTRO)
1604             DIE(aTHX_ "Can't localize pseudo-hash element");
1605         svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1606     }
1607     else {
1608         RETPUSHUNDEF;
1609     }
1610     if (lval) {
1611         if (!svp || *svp == &PL_sv_undef) {
1612             SV* lv;
1613             SV* key2;
1614             if (!defer) {
1615                 STRLEN n_a;
1616                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1617             }
1618             lv = sv_newmortal();
1619             sv_upgrade(lv, SVt_PVLV);
1620             LvTYPE(lv) = 'y';
1621             sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1622             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1623             LvTARG(lv) = SvREFCNT_inc(hv);
1624             LvTARGLEN(lv) = 1;
1625             PUSHs(lv);
1626             RETURN;
1627         }
1628         if (PL_op->op_private & OPpLVAL_INTRO) {
1629             if (HvNAME(hv) && isGV(*svp))
1630                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1631             else {
1632                 if (!preeminent) {
1633                     STRLEN keylen;
1634                     char *key = SvPV(keysv, keylen);
1635                     save_delete(hv, key, keylen);
1636                 } else
1637                     save_helem(hv, keysv, svp);
1638             }
1639         }
1640         else if (PL_op->op_private & OPpDEREF)
1641             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1642     }
1643     sv = (svp ? *svp : &PL_sv_undef);
1644     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1645      * Pushing the magical RHS on to the stack is useless, since
1646      * that magic is soon destined to be misled by the local(),
1647      * and thus the later pp_sassign() will fail to mg_get() the
1648      * old value.  This should also cure problems with delayed
1649      * mg_get()s.  GSAR 98-07-03 */
1650     if (!lval && SvGMAGICAL(sv))
1651         sv = sv_mortalcopy(sv);
1652     PUSHs(sv);
1653     RETURN;
1654 }
1655
1656 PP(pp_leave)
1657 {
1658     djSP;
1659     register PERL_CONTEXT *cx;
1660     register SV **mark;
1661     SV **newsp;
1662     PMOP *newpm;
1663     I32 gimme;
1664
1665     if (PL_op->op_flags & OPf_SPECIAL) {
1666         cx = &cxstack[cxstack_ix];
1667         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1668     }
1669
1670     POPBLOCK(cx,newpm);
1671
1672     gimme = OP_GIMME(PL_op, -1);
1673     if (gimme == -1) {
1674         if (cxstack_ix >= 0)
1675             gimme = cxstack[cxstack_ix].blk_gimme;
1676         else
1677             gimme = G_SCALAR;
1678     }
1679
1680     TAINT_NOT;
1681     if (gimme == G_VOID)
1682         SP = newsp;
1683     else if (gimme == G_SCALAR) {
1684         MARK = newsp + 1;
1685         if (MARK <= SP)
1686             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1687                 *MARK = TOPs;
1688             else
1689                 *MARK = sv_mortalcopy(TOPs);
1690         else {
1691             MEXTEND(mark,0);
1692             *MARK = &PL_sv_undef;
1693         }
1694         SP = MARK;
1695     }
1696     else if (gimme == G_ARRAY) {
1697         /* in case LEAVE wipes old return values */
1698         for (mark = newsp + 1; mark <= SP; mark++) {
1699             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1700                 *mark = sv_mortalcopy(*mark);
1701                 TAINT_NOT;      /* Each item is independent */
1702             }
1703         }
1704     }
1705     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1706
1707     LEAVE;
1708
1709     RETURN;
1710 }
1711
1712 PP(pp_iter)
1713 {
1714     djSP;
1715     register PERL_CONTEXT *cx;
1716     SV* sv;
1717     AV* av;
1718     SV **itersvp;
1719
1720     EXTEND(SP, 1);
1721     cx = &cxstack[cxstack_ix];
1722     if (CxTYPE(cx) != CXt_LOOP)
1723         DIE(aTHX_ "panic: pp_iter");
1724
1725     itersvp = CxITERVAR(cx);
1726     av = cx->blk_loop.iterary;
1727     if (SvTYPE(av) != SVt_PVAV) {
1728         /* iterate ($min .. $max) */
1729         if (cx->blk_loop.iterlval) {
1730             /* string increment */
1731             register SV* cur = cx->blk_loop.iterlval;
1732             STRLEN maxlen;
1733             char *max = SvPV((SV*)av, maxlen);
1734             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1735 #ifndef USE_THREADS                       /* don't risk potential race */
1736                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1737                     /* safe to reuse old SV */
1738                     sv_setsv(*itersvp, cur);
1739                 }
1740                 else
1741 #endif
1742                 {
1743                     /* we need a fresh SV every time so that loop body sees a
1744                      * completely new SV for closures/references to work as
1745                      * they used to */
1746                     SvREFCNT_dec(*itersvp);
1747                     *itersvp = newSVsv(cur);
1748                 }
1749                 if (strEQ(SvPVX(cur), max))
1750                     sv_setiv(cur, 0); /* terminate next time */
1751                 else
1752                     sv_inc(cur);
1753                 RETPUSHYES;
1754             }
1755             RETPUSHNO;
1756         }
1757         /* integer increment */
1758         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1759             RETPUSHNO;
1760
1761 #ifndef USE_THREADS                       /* don't risk potential race */
1762         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1763             /* safe to reuse old SV */
1764             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1765         }
1766         else
1767 #endif
1768         {
1769             /* we need a fresh SV every time so that loop body sees a
1770              * completely new SV for closures/references to work as they
1771              * used to */
1772             SvREFCNT_dec(*itersvp);
1773             *itersvp = newSViv(cx->blk_loop.iterix++);
1774         }
1775         RETPUSHYES;
1776     }
1777
1778     /* iterate array */
1779     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1780         RETPUSHNO;
1781
1782     SvREFCNT_dec(*itersvp);
1783
1784     if ((sv = SvMAGICAL(av)
1785               ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1786               : AvARRAY(av)[++cx->blk_loop.iterix]))
1787         SvTEMP_off(sv);
1788     else
1789         sv = &PL_sv_undef;
1790     if (av != PL_curstack && SvIMMORTAL(sv)) {
1791         SV *lv = cx->blk_loop.iterlval;
1792         if (lv && SvREFCNT(lv) > 1) {
1793             SvREFCNT_dec(lv);
1794             lv = Nullsv;
1795         }
1796         if (lv)
1797             SvREFCNT_dec(LvTARG(lv));
1798         else {
1799             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1800             sv_upgrade(lv, SVt_PVLV);
1801             LvTYPE(lv) = 'y';
1802             sv_magic(lv, Nullsv, 'y', Nullch, 0);
1803         }
1804         LvTARG(lv) = SvREFCNT_inc(av);
1805         LvTARGOFF(lv) = cx->blk_loop.iterix;
1806         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1807         sv = (SV*)lv;
1808     }
1809
1810     *itersvp = SvREFCNT_inc(sv);
1811     RETPUSHYES;
1812 }
1813
1814 PP(pp_subst)
1815 {
1816     djSP; dTARG;
1817     register PMOP *pm = cPMOP;
1818     PMOP *rpm = pm;
1819     register SV *dstr;
1820     register char *s;
1821     char *strend;
1822     register char *m;
1823     char *c;
1824     register char *d;
1825     STRLEN clen;
1826     I32 iters = 0;
1827     I32 maxiters;
1828     register I32 i;
1829     bool once;
1830     bool rxtainted;
1831     char *orig;
1832     I32 r_flags;
1833     register REGEXP *rx = pm->op_pmregexp;
1834     STRLEN len;
1835     int force_on_match = 0;
1836     I32 oldsave = PL_savestack_ix;
1837     bool do_utf8;
1838     STRLEN slen;
1839
1840     /* known replacement string? */
1841     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1842     if (PL_op->op_flags & OPf_STACKED)
1843         TARG = POPs;
1844     else {
1845         TARG = DEFSV;
1846         EXTEND(SP,1);
1847     }
1848     PL_reg_sv = TARG;
1849     do_utf8 = DO_UTF8(PL_reg_sv);
1850     if (SvFAKE(TARG) && SvREADONLY(TARG))
1851         sv_force_normal(TARG);
1852     if (SvREADONLY(TARG)
1853         || (SvTYPE(TARG) > SVt_PVLV
1854             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1855         DIE(aTHX_ PL_no_modify);
1856     PUTBACK;
1857
1858     s = SvPV(TARG, len);
1859     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1860         force_on_match = 1;
1861     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1862                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1863     if (PL_tainted)
1864         rxtainted |= 2;
1865     TAINT_NOT;
1866
1867   force_it:
1868     if (!pm || !s)
1869         DIE(aTHX_ "panic: pp_subst");
1870
1871     strend = s + len;
1872     slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1873     maxiters = 2 * slen + 10;   /* We can match twice at each
1874                                    position, once with zero-length,
1875                                    second time with non-zero. */
1876
1877     if (!rx->prelen && PL_curpm) {
1878         pm = PL_curpm;
1879         rx = pm->op_pmregexp;
1880     }
1881     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1882                 ? REXEC_COPY_STR : 0;
1883     if (SvSCREAM(TARG))
1884         r_flags |= REXEC_SCREAM;
1885     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1886         SAVEINT(PL_multiline);
1887         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1888     }
1889     orig = m = s;
1890     if (rx->reganch & RE_USE_INTUIT) {
1891         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1892
1893         if (!s)
1894             goto nope;
1895         /* How to do it in subst? */
1896 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
1897              && !PL_sawampersand
1898              && ((rx->reganch & ROPT_NOSCAN)
1899                  || !((rx->reganch & RE_INTUIT_TAIL)
1900                       && (r_flags & REXEC_SCREAM))))
1901             goto yup;
1902 */
1903     }
1904
1905     /* only replace once? */
1906     once = !(rpm->op_pmflags & PMf_GLOBAL);
1907
1908     /* known replacement string? */
1909     c = dstr ? SvPV(dstr, clen) : Nullch;
1910
1911     /* can do inplace substitution? */
1912     if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1913         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1914         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1915                          r_flags | REXEC_CHECKED))
1916         {
1917             SPAGAIN;
1918             PUSHs(&PL_sv_no);
1919             LEAVE_SCOPE(oldsave);
1920             RETURN;
1921         }
1922         if (force_on_match) {
1923             force_on_match = 0;
1924             s = SvPV_force(TARG, len);
1925             goto force_it;
1926         }
1927         d = s;
1928         PL_curpm = pm;
1929         SvSCREAM_off(TARG);     /* disable possible screamer */
1930         if (once) {
1931             rxtainted |= RX_MATCH_TAINTED(rx);
1932             m = orig + rx->startp[0];
1933             d = orig + rx->endp[0];
1934             s = orig;
1935             if (m - s > strend - d) {  /* faster to shorten from end */
1936                 if (clen) {
1937                     Copy(c, m, clen, char);
1938                     m += clen;
1939                 }
1940                 i = strend - d;
1941                 if (i > 0) {
1942                     Move(d, m, i, char);
1943                     m += i;
1944                 }
1945                 *m = '\0';
1946                 SvCUR_set(TARG, m - s);
1947             }
1948             /*SUPPRESS 560*/
1949             else if ((i = m - s)) {     /* faster from front */
1950                 d -= clen;
1951                 m = d;
1952                 sv_chop(TARG, d-i);
1953                 s += i;
1954                 while (i--)
1955                     *--d = *--s;
1956                 if (clen)
1957                     Copy(c, m, clen, char);
1958             }
1959             else if (clen) {
1960                 d -= clen;
1961                 sv_chop(TARG, d);
1962                 Copy(c, d, clen, char);
1963             }
1964             else {
1965                 sv_chop(TARG, d);
1966             }
1967             TAINT_IF(rxtainted & 1);
1968             SPAGAIN;
1969             PUSHs(&PL_sv_yes);
1970         }
1971         else {
1972             do {
1973                 if (iters++ > maxiters)
1974                     DIE(aTHX_ "Substitution loop");
1975                 rxtainted |= RX_MATCH_TAINTED(rx);
1976                 m = rx->startp[0] + orig;
1977                 /*SUPPRESS 560*/
1978                 if ((i = m - s)) {
1979                     if (s != d)
1980                         Move(s, d, i, char);
1981                     d += i;
1982                 }
1983                 if (clen) {
1984                     Copy(c, d, clen, char);
1985                     d += clen;
1986                 }
1987                 s = rx->endp[0] + orig;
1988             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
1989                                  TARG, NULL,
1990                                  /* don't match same null twice */
1991                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
1992             if (s != d) {
1993                 i = strend - s;
1994                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1995                 Move(s, d, i+1, char);          /* include the NUL */
1996             }
1997             TAINT_IF(rxtainted & 1);
1998             SPAGAIN;
1999             PUSHs(sv_2mortal(newSViv((I32)iters)));
2000         }
2001         (void)SvPOK_only_UTF8(TARG);
2002         TAINT_IF(rxtainted);
2003         if (SvSMAGICAL(TARG)) {
2004             PUTBACK;
2005             mg_set(TARG);
2006             SPAGAIN;
2007         }
2008         SvTAINT(TARG);
2009         LEAVE_SCOPE(oldsave);
2010         RETURN;
2011     }
2012
2013     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2014                     r_flags | REXEC_CHECKED))
2015     {
2016         bool isutf8;
2017
2018         if (force_on_match) {
2019             force_on_match = 0;
2020             s = SvPV_force(TARG, len);
2021             goto force_it;
2022         }
2023         rxtainted |= RX_MATCH_TAINTED(rx);
2024         dstr = NEWSV(25, len);
2025         sv_setpvn(dstr, m, s-m);
2026         if (DO_UTF8(TARG))
2027             SvUTF8_on(dstr);
2028         PL_curpm = pm;
2029         if (!c) {
2030             register PERL_CONTEXT *cx;
2031             SPAGAIN;
2032             PUSHSUBST(cx);
2033             RETURNOP(cPMOP->op_pmreplroot);
2034         }
2035         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2036         do {
2037             if (iters++ > maxiters)
2038                 DIE(aTHX_ "Substitution loop");
2039             rxtainted |= RX_MATCH_TAINTED(rx);
2040             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2041                 m = s;
2042                 s = orig;
2043                 orig = rx->subbeg;
2044                 s = orig + (m - s);
2045                 strend = s + (strend - m);
2046             }
2047             m = rx->startp[0] + orig;
2048             sv_catpvn(dstr, s, m-s);
2049             s = rx->endp[0] + orig;
2050             if (clen)
2051                 sv_catpvn(dstr, c, clen);
2052             if (once)
2053                 break;
2054         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2055                              TARG, NULL, r_flags));
2056         sv_catpvn(dstr, s, strend - s);
2057
2058         (void)SvOOK_off(TARG);
2059         Safefree(SvPVX(TARG));
2060         SvPVX(TARG) = SvPVX(dstr);
2061         SvCUR_set(TARG, SvCUR(dstr));
2062         SvLEN_set(TARG, SvLEN(dstr));
2063         isutf8 = DO_UTF8(dstr);
2064         SvPVX(dstr) = 0;
2065         sv_free(dstr);
2066
2067         TAINT_IF(rxtainted & 1);
2068         SPAGAIN;
2069         PUSHs(sv_2mortal(newSViv((I32)iters)));
2070
2071         (void)SvPOK_only(TARG);
2072         if (isutf8)
2073             SvUTF8_on(TARG);
2074         TAINT_IF(rxtainted);
2075         SvSETMAGIC(TARG);
2076         SvTAINT(TARG);
2077         LEAVE_SCOPE(oldsave);
2078         RETURN;
2079     }
2080     goto ret_no;
2081
2082 nope:
2083 ret_no:
2084     SPAGAIN;
2085     PUSHs(&PL_sv_no);
2086     LEAVE_SCOPE(oldsave);
2087     RETURN;
2088 }
2089
2090 PP(pp_grepwhile)
2091 {
2092     djSP;
2093
2094     if (SvTRUEx(POPs))
2095         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2096     ++*PL_markstack_ptr;
2097     LEAVE;                                      /* exit inner scope */
2098
2099     /* All done yet? */
2100     if (PL_stack_base + *PL_markstack_ptr > SP) {
2101         I32 items;
2102         I32 gimme = GIMME_V;
2103
2104         LEAVE;                                  /* exit outer scope */
2105         (void)POPMARK;                          /* pop src */
2106         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2107         (void)POPMARK;                          /* pop dst */
2108         SP = PL_stack_base + POPMARK;           /* pop original mark */
2109         if (gimme == G_SCALAR) {
2110             dTARGET;
2111             XPUSHi(items);
2112         }
2113         else if (gimme == G_ARRAY)
2114             SP += items;
2115         RETURN;
2116     }
2117     else {
2118         SV *src;
2119
2120         ENTER;                                  /* enter inner scope */
2121         SAVEVPTR(PL_curpm);
2122
2123         src = PL_stack_base[*PL_markstack_ptr];
2124         SvTEMP_off(src);
2125         DEFSV = src;
2126
2127         RETURNOP(cLOGOP->op_other);
2128     }
2129 }
2130
2131 PP(pp_leavesub)
2132 {
2133     djSP;
2134     SV **mark;
2135     SV **newsp;
2136     PMOP *newpm;
2137     I32 gimme;
2138     register PERL_CONTEXT *cx;
2139     SV *sv;
2140
2141     POPBLOCK(cx,newpm);
2142
2143     TAINT_NOT;
2144     if (gimme == G_SCALAR) {
2145         MARK = newsp + 1;
2146         if (MARK <= SP) {
2147             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2148                 if (SvTEMP(TOPs)) {
2149                     *MARK = SvREFCNT_inc(TOPs);
2150                     FREETMPS;
2151                     sv_2mortal(*MARK);
2152                 }
2153                 else {
2154                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2155                     FREETMPS;
2156                     *MARK = sv_mortalcopy(sv);
2157                     SvREFCNT_dec(sv);
2158                 }
2159             }
2160             else
2161                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2162         }
2163         else {
2164             MEXTEND(MARK, 0);
2165             *MARK = &PL_sv_undef;
2166         }
2167         SP = MARK;
2168     }
2169     else if (gimme == G_ARRAY) {
2170         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2171             if (!SvTEMP(*MARK)) {
2172                 *MARK = sv_mortalcopy(*MARK);
2173                 TAINT_NOT;      /* Each item is independent */
2174             }
2175         }
2176     }
2177     PUTBACK;
2178
2179     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2180     PL_curpm = newpm;   /* ... and pop $1 et al */
2181
2182     LEAVE;
2183     LEAVESUB(sv);
2184     return pop_return();
2185 }
2186
2187 /* This duplicates the above code because the above code must not
2188  * get any slower by more conditions */
2189 PP(pp_leavesublv)
2190 {
2191     djSP;
2192     SV **mark;
2193     SV **newsp;
2194     PMOP *newpm;
2195     I32 gimme;
2196     register PERL_CONTEXT *cx;
2197     SV *sv;
2198
2199     POPBLOCK(cx,newpm);
2200
2201     TAINT_NOT;
2202
2203     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2204         /* We are an argument to a function or grep().
2205          * This kind of lvalueness was legal before lvalue
2206          * subroutines too, so be backward compatible:
2207          * cannot report errors.  */
2208
2209         /* Scalar context *is* possible, on the LHS of -> only,
2210          * as in f()->meth().  But this is not an lvalue. */
2211         if (gimme == G_SCALAR)
2212             goto temporise;
2213         if (gimme == G_ARRAY) {
2214             if (!CvLVALUE(cx->blk_sub.cv))
2215                 goto temporise_array;
2216             EXTEND_MORTAL(SP - newsp);
2217             for (mark = newsp + 1; mark <= SP; mark++) {
2218                 if (SvTEMP(*mark))
2219                     /* empty */ ;
2220                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2221                     *mark = sv_mortalcopy(*mark);
2222                 else {
2223                     /* Can be a localized value subject to deletion. */
2224                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2225                     (void)SvREFCNT_inc(*mark);
2226                 }
2227             }
2228         }
2229     }
2230     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2231         /* Here we go for robustness, not for speed, so we change all
2232          * the refcounts so the caller gets a live guy. Cannot set
2233          * TEMP, so sv_2mortal is out of question. */
2234         if (!CvLVALUE(cx->blk_sub.cv)) {
2235             POPSUB(cx,sv);
2236             PL_curpm = newpm;
2237             LEAVE;
2238             LEAVESUB(sv);
2239             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2240         }
2241         if (gimme == G_SCALAR) {
2242             MARK = newsp + 1;
2243             EXTEND_MORTAL(1);
2244             if (MARK == SP) {
2245                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2246                     POPSUB(cx,sv);
2247                     PL_curpm = newpm;
2248                     LEAVE;
2249                     LEAVESUB(sv);
2250                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2251                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2252                 }
2253                 else {                  /* Can be a localized value
2254                                          * subject to deletion. */
2255                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2256                     (void)SvREFCNT_inc(*mark);
2257                 }
2258             }
2259             else {                      /* Should not happen? */
2260                 POPSUB(cx,sv);
2261                 PL_curpm = newpm;
2262                 LEAVE;
2263                 LEAVESUB(sv);
2264                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2265                     (MARK > SP ? "Empty array" : "Array"));
2266             }
2267             SP = MARK;
2268         }
2269         else if (gimme == G_ARRAY) {
2270             EXTEND_MORTAL(SP - newsp);
2271             for (mark = newsp + 1; mark <= SP; mark++) {
2272                 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2273                     /* Might be flattened array after $#array =  */
2274                     PUTBACK;
2275                     POPSUB(cx,sv);
2276                     PL_curpm = newpm;
2277                     LEAVE;
2278                     LEAVESUB(sv);
2279                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2280                         (*mark != &PL_sv_undef)
2281                         ? (SvREADONLY(TOPs)
2282                             ? "a readonly value" : "a temporary")
2283                         : "an uninitialized value");
2284                 }
2285                 else {
2286                     /* Can be a localized value subject to deletion. */
2287                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2288                     (void)SvREFCNT_inc(*mark);
2289                 }
2290             }
2291         }
2292     }
2293     else {
2294         if (gimme == G_SCALAR) {
2295           temporise:
2296             MARK = newsp + 1;
2297             if (MARK <= SP) {
2298                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2299                     if (SvTEMP(TOPs)) {
2300                         *MARK = SvREFCNT_inc(TOPs);
2301                         FREETMPS;
2302                         sv_2mortal(*MARK);
2303                     }
2304                     else {
2305                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2306                         FREETMPS;
2307                         *MARK = sv_mortalcopy(sv);
2308                         SvREFCNT_dec(sv);
2309                     }
2310                 }
2311                 else
2312                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2313             }
2314             else {
2315                 MEXTEND(MARK, 0);
2316                 *MARK = &PL_sv_undef;
2317             }
2318             SP = MARK;
2319         }
2320         else if (gimme == G_ARRAY) {
2321           temporise_array:
2322             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2323                 if (!SvTEMP(*MARK)) {
2324                     *MARK = sv_mortalcopy(*MARK);
2325                     TAINT_NOT;  /* Each item is independent */
2326                 }
2327             }
2328         }
2329     }
2330     PUTBACK;
2331
2332     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2333     PL_curpm = newpm;   /* ... and pop $1 et al */
2334
2335     LEAVE;
2336     LEAVESUB(sv);
2337     return pop_return();
2338 }
2339
2340
2341 STATIC CV *
2342 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2343 {
2344     SV *dbsv = GvSV(PL_DBsub);
2345
2346     if (!PERLDB_SUB_NN) {
2347         GV *gv = CvGV(cv);
2348
2349         save_item(dbsv);
2350         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2351              || strEQ(GvNAME(gv), "END")
2352              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2353                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2354                     && (gv = (GV*)*svp) ))) {
2355             /* Use GV from the stack as a fallback. */
2356             /* GV is potentially non-unique, or contain different CV. */
2357             SV *tmp = newRV((SV*)cv);
2358             sv_setsv(dbsv, tmp);
2359             SvREFCNT_dec(tmp);
2360         }
2361         else {
2362             gv_efullname3(dbsv, gv, Nullch);
2363         }
2364     }
2365     else {
2366         (void)SvUPGRADE(dbsv, SVt_PVIV);
2367         (void)SvIOK_on(dbsv);
2368         SAVEIV(SvIVX(dbsv));
2369         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2370     }
2371
2372     if (CvXSUB(cv))
2373         PL_curcopdb = PL_curcop;
2374     cv = GvCV(PL_DBsub);
2375     return cv;
2376 }
2377
2378 PP(pp_entersub)
2379 {
2380     djSP; dPOPss;
2381     GV *gv;
2382     HV *stash;
2383     register CV *cv;
2384     register PERL_CONTEXT *cx;
2385     I32 gimme;
2386     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2387
2388     if (!sv)
2389         DIE(aTHX_ "Not a CODE reference");
2390     switch (SvTYPE(sv)) {
2391     default:
2392         if (!SvROK(sv)) {
2393             char *sym;
2394             STRLEN n_a;
2395
2396             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2397                 if (hasargs)
2398                     SP = PL_stack_base + POPMARK;
2399                 RETURN;
2400             }
2401             if (SvGMAGICAL(sv)) {
2402                 mg_get(sv);
2403                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2404             }
2405             else
2406                 sym = SvPV(sv, n_a);
2407             if (!sym)
2408                 DIE(aTHX_ PL_no_usym, "a subroutine");
2409             if (PL_op->op_private & HINT_STRICT_REFS)
2410                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2411             cv = get_cv(sym, TRUE);
2412             break;
2413         }
2414         {
2415             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2416             tryAMAGICunDEREF(to_cv);
2417         }       
2418         cv = (CV*)SvRV(sv);
2419         if (SvTYPE(cv) == SVt_PVCV)
2420             break;
2421         /* FALL THROUGH */
2422     case SVt_PVHV:
2423     case SVt_PVAV:
2424         DIE(aTHX_ "Not a CODE reference");
2425     case SVt_PVCV:
2426         cv = (CV*)sv;
2427         break;
2428     case SVt_PVGV:
2429         if (!(cv = GvCVu((GV*)sv)))
2430             cv = sv_2cv(sv, &stash, &gv, FALSE);
2431         if (!cv) {
2432             ENTER;
2433             SAVETMPS;
2434             goto try_autoload;
2435         }
2436         break;
2437     }
2438
2439     ENTER;
2440     SAVETMPS;
2441
2442   retry:
2443     if (!CvROOT(cv) && !CvXSUB(cv)) {
2444         GV* autogv;
2445         SV* sub_name;
2446
2447         /* anonymous or undef'd function leaves us no recourse */
2448         if (CvANON(cv) || !(gv = CvGV(cv)))
2449             DIE(aTHX_ "Undefined subroutine called");
2450
2451         /* autoloaded stub? */
2452         if (cv != GvCV(gv)) {
2453             cv = GvCV(gv);
2454         }
2455         /* should call AUTOLOAD now? */
2456         else {
2457 try_autoload:
2458             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2459                                    FALSE)))
2460             {
2461                 cv = GvCV(autogv);
2462             }
2463             /* sorry */
2464             else {
2465                 sub_name = sv_newmortal();
2466                 gv_efullname3(sub_name, gv, Nullch);
2467                 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2468             }
2469         }
2470         if (!cv)
2471             DIE(aTHX_ "Not a CODE reference");
2472         goto retry;
2473     }
2474
2475     gimme = GIMME_V;
2476     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2477         cv = get_db_sub(&sv, cv);
2478         if (!cv)
2479             DIE(aTHX_ "No DBsub routine");
2480     }
2481
2482 #ifdef USE_THREADS
2483     /*
2484      * First we need to check if the sub or method requires locking.
2485      * If so, we gain a lock on the CV, the first argument or the
2486      * stash (for static methods), as appropriate. This has to be
2487      * inline because for FAKE_THREADS, COND_WAIT inlines code to
2488      * reschedule by returning a new op.
2489      */
2490     MUTEX_LOCK(CvMUTEXP(cv));
2491     if (CvFLAGS(cv) & CVf_LOCKED) {
2492         MAGIC *mg;      
2493         if (CvFLAGS(cv) & CVf_METHOD) {
2494             if (SP > PL_stack_base + TOPMARK)
2495                 sv = *(PL_stack_base + TOPMARK + 1);
2496             else {
2497                 AV *av = (AV*)PL_curpad[0];
2498                 if (hasargs || !av || AvFILLp(av) < 0
2499                     || !(sv = AvARRAY(av)[0]))
2500                 {
2501                     MUTEX_UNLOCK(CvMUTEXP(cv));
2502                     DIE(aTHX_ "no argument for locked method call");
2503                 }
2504             }
2505             if (SvROK(sv))
2506                 sv = SvRV(sv);
2507             else {              
2508                 STRLEN len;
2509                 char *stashname = SvPV(sv, len);
2510                 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2511             }
2512         }
2513         else {
2514             sv = (SV*)cv;
2515         }
2516         MUTEX_UNLOCK(CvMUTEXP(cv));
2517         mg = condpair_magic(sv);
2518         MUTEX_LOCK(MgMUTEXP(mg));
2519         if (MgOWNER(mg) == thr)
2520             MUTEX_UNLOCK(MgMUTEXP(mg));
2521         else {
2522             while (MgOWNER(mg))
2523                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2524             MgOWNER(mg) = thr;
2525             DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2526                                   thr, sv);)
2527             MUTEX_UNLOCK(MgMUTEXP(mg));
2528             SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2529         }
2530         MUTEX_LOCK(CvMUTEXP(cv));
2531     }
2532     /*
2533      * Now we have permission to enter the sub, we must distinguish
2534      * four cases. (0) It's an XSUB (in which case we don't care
2535      * about ownership); (1) it's ours already (and we're recursing);
2536      * (2) it's free (but we may already be using a cached clone);
2537      * (3) another thread owns it. Case (1) is easy: we just use it.
2538      * Case (2) means we look for a clone--if we have one, use it
2539      * otherwise grab ownership of cv. Case (3) means we look for a
2540      * clone (for non-XSUBs) and have to create one if we don't
2541      * already have one.
2542      * Why look for a clone in case (2) when we could just grab
2543      * ownership of cv straight away? Well, we could be recursing,
2544      * i.e. we originally tried to enter cv while another thread
2545      * owned it (hence we used a clone) but it has been freed up
2546      * and we're now recursing into it. It may or may not be "better"
2547      * to use the clone but at least CvDEPTH can be trusted.
2548      */
2549     if (CvOWNER(cv) == thr || CvXSUB(cv))
2550         MUTEX_UNLOCK(CvMUTEXP(cv));
2551     else {
2552         /* Case (2) or (3) */
2553         SV **svp;
2554         
2555         /*
2556          * XXX Might it be better to release CvMUTEXP(cv) while we
2557          * do the hv_fetch? We might find someone has pinched it
2558          * when we look again, in which case we would be in case
2559          * (3) instead of (2) so we'd have to clone. Would the fact
2560          * that we released the mutex more quickly make up for this?
2561          */
2562         if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2563         {
2564             /* We already have a clone to use */
2565             MUTEX_UNLOCK(CvMUTEXP(cv));
2566             cv = *(CV**)svp;
2567             DEBUG_S(PerlIO_printf(Perl_debug_log,
2568                                   "entersub: %p already has clone %p:%s\n",
2569                                   thr, cv, SvPEEK((SV*)cv)));
2570             CvOWNER(cv) = thr;
2571             SvREFCNT_inc(cv);
2572             if (CvDEPTH(cv) == 0)
2573                 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2574         }
2575         else {
2576             /* (2) => grab ownership of cv. (3) => make clone */
2577             if (!CvOWNER(cv)) {
2578                 CvOWNER(cv) = thr;
2579                 SvREFCNT_inc(cv);
2580                 MUTEX_UNLOCK(CvMUTEXP(cv));
2581                 DEBUG_S(PerlIO_printf(Perl_debug_log,
2582                             "entersub: %p grabbing %p:%s in stash %s\n",
2583                             thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2584                                 HvNAME(CvSTASH(cv)) : "(none)"));
2585             }
2586             else {
2587                 /* Make a new clone. */
2588                 CV *clonecv;
2589                 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2590                 MUTEX_UNLOCK(CvMUTEXP(cv));
2591                 DEBUG_S((PerlIO_printf(Perl_debug_log,
2592                                        "entersub: %p cloning %p:%s\n",
2593                                        thr, cv, SvPEEK((SV*)cv))));
2594                 /*
2595                  * We're creating a new clone so there's no race
2596                  * between the original MUTEX_UNLOCK and the
2597                  * SvREFCNT_inc since no one will be trying to undef
2598                  * it out from underneath us. At least, I don't think
2599                  * there's a race...
2600                  */
2601                 clonecv = cv_clone(cv);
2602                 SvREFCNT_dec(cv); /* finished with this */
2603                 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2604                 CvOWNER(clonecv) = thr;
2605                 cv = clonecv;
2606                 SvREFCNT_inc(cv);
2607             }
2608             DEBUG_S(if (CvDEPTH(cv) != 0)
2609                         PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2610                                       CvDEPTH(cv)););
2611             SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2612         }
2613     }
2614 #endif /* USE_THREADS */
2615
2616     if (CvXSUB(cv)) {
2617 #ifdef PERL_XSUB_OLDSTYLE
2618         if (CvOLDSTYLE(cv)) {
2619             I32 (*fp3)(int,int,int);
2620             dMARK;
2621             register I32 items = SP - MARK;
2622                                         /* We dont worry to copy from @_. */
2623             while (SP > mark) {
2624                 SP[1] = SP[0];
2625                 SP--;
2626             }
2627             PL_stack_sp = mark + 1;
2628             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2629             items = (*fp3)(CvXSUBANY(cv).any_i32,
2630                            MARK - PL_stack_base + 1,
2631                            items);
2632             PL_stack_sp = PL_stack_base + items;
2633         }
2634         else
2635 #endif /* PERL_XSUB_OLDSTYLE */
2636         {
2637             I32 markix = TOPMARK;
2638
2639             PUTBACK;
2640
2641             if (!hasargs) {
2642                 /* Need to copy @_ to stack. Alternative may be to
2643                  * switch stack to @_, and copy return values
2644                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2645                 AV* av;
2646                 I32 items;
2647 #ifdef USE_THREADS
2648                 av = (AV*)PL_curpad[0];
2649 #else
2650                 av = GvAV(PL_defgv);
2651 #endif /* USE_THREADS */                
2652                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2653
2654                 if (items) {
2655                     /* Mark is at the end of the stack. */
2656                     EXTEND(SP, items);
2657                     Copy(AvARRAY(av), SP + 1, items, SV*);
2658                     SP += items;
2659                     PUTBACK ;           
2660                 }
2661             }
2662             /* We assume first XSUB in &DB::sub is the called one. */
2663             if (PL_curcopdb) {
2664                 SAVEVPTR(PL_curcop);
2665                 PL_curcop = PL_curcopdb;
2666                 PL_curcopdb = NULL;
2667             }
2668             /* Do we need to open block here? XXXX */
2669             (void)(*CvXSUB(cv))(aTHXo_ cv);
2670
2671             /* Enforce some sanity in scalar context. */
2672             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2673                 if (markix > PL_stack_sp - PL_stack_base)
2674                     *(PL_stack_base + markix) = &PL_sv_undef;
2675                 else
2676                     *(PL_stack_base + markix) = *PL_stack_sp;
2677                 PL_stack_sp = PL_stack_base + markix;
2678             }
2679         }
2680         LEAVE;
2681         return NORMAL;
2682     }
2683     else {
2684         dMARK;
2685         register I32 items = SP - MARK;
2686         AV* padlist = CvPADLIST(cv);
2687         SV** svp = AvARRAY(padlist);
2688         push_return(PL_op->op_next);
2689         PUSHBLOCK(cx, CXt_SUB, MARK);
2690         PUSHSUB(cx);
2691         CvDEPTH(cv)++;
2692         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2693          * that eval'' ops within this sub know the correct lexical space.
2694          * Owing the speed considerations, we choose to search for the cv
2695          * in doeval() instead.
2696          */
2697         if (CvDEPTH(cv) < 2)
2698             (void)SvREFCNT_inc(cv);
2699         else {  /* save temporaries on recursion? */
2700             PERL_STACK_OVERFLOW_CHECK();
2701             if (CvDEPTH(cv) > AvFILLp(padlist)) {
2702                 AV *av;
2703                 AV *newpad = newAV();
2704                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2705                 I32 ix = AvFILLp((AV*)svp[1]);
2706                 I32 names_fill = AvFILLp((AV*)svp[0]);
2707                 svp = AvARRAY(svp[0]);
2708                 for ( ;ix > 0; ix--) {
2709                     if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2710                         char *name = SvPVX(svp[ix]);
2711                         if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2712                             || *name == '&')              /* anonymous code? */
2713                         {
2714                             av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2715                         }
2716                         else {                          /* our own lexical */
2717                             if (*name == '@')
2718                                 av_store(newpad, ix, sv = (SV*)newAV());
2719                             else if (*name == '%')
2720                                 av_store(newpad, ix, sv = (SV*)newHV());
2721                             else
2722                                 av_store(newpad, ix, sv = NEWSV(0,0));
2723                             SvPADMY_on(sv);
2724                         }
2725                     }
2726                     else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2727                         av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2728                     }
2729                     else {
2730                         av_store(newpad, ix, sv = NEWSV(0,0));
2731                         SvPADTMP_on(sv);
2732                     }
2733                 }
2734                 av = newAV();           /* will be @_ */
2735                 av_extend(av, 0);
2736                 av_store(newpad, 0, (SV*)av);
2737                 AvFLAGS(av) = AVf_REIFY;
2738                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2739                 AvFILLp(padlist) = CvDEPTH(cv);
2740                 svp = AvARRAY(padlist);
2741             }
2742         }
2743 #ifdef USE_THREADS
2744         if (!hasargs) {
2745             AV* av = (AV*)PL_curpad[0];
2746
2747             items = AvFILLp(av) + 1;
2748             if (items) {
2749                 /* Mark is at the end of the stack. */
2750                 EXTEND(SP, items);
2751                 Copy(AvARRAY(av), SP + 1, items, SV*);
2752                 SP += items;
2753                 PUTBACK ;               
2754             }
2755         }
2756 #endif /* USE_THREADS */                
2757         SAVEVPTR(PL_curpad);
2758         PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2759 #ifndef USE_THREADS
2760         if (hasargs)
2761 #endif /* USE_THREADS */
2762         {
2763             AV* av;
2764             SV** ary;
2765
2766 #if 0
2767             DEBUG_S(PerlIO_printf(Perl_debug_log,
2768                                   "%p entersub preparing @_\n", thr));
2769 #endif
2770             av = (AV*)PL_curpad[0];
2771             if (AvREAL(av)) {
2772                 /* @_ is normally not REAL--this should only ever
2773                  * happen when DB::sub() calls things that modify @_ */
2774                 av_clear(av);
2775                 AvREAL_off(av);
2776                 AvREIFY_on(av);
2777             }
2778 #ifndef USE_THREADS
2779             cx->blk_sub.savearray = GvAV(PL_defgv);
2780             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2781 #endif /* USE_THREADS */
2782             cx->blk_sub.oldcurpad = PL_curpad;
2783             cx->blk_sub.argarray = av;
2784             ++MARK;
2785
2786             if (items > AvMAX(av) + 1) {
2787                 ary = AvALLOC(av);
2788                 if (AvARRAY(av) != ary) {
2789                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2790                     SvPVX(av) = (char*)ary;
2791                 }
2792                 if (items > AvMAX(av) + 1) {
2793                     AvMAX(av) = items - 1;
2794                     Renew(ary,items,SV*);
2795                     AvALLOC(av) = ary;
2796                     SvPVX(av) = (char*)ary;
2797                 }
2798             }
2799             Copy(MARK,AvARRAY(av),items,SV*);
2800             AvFILLp(av) = items - 1;
2801         
2802             while (items--) {
2803                 if (*MARK)
2804                     SvTEMP_off(*MARK);
2805                 MARK++;
2806             }
2807         }
2808         /* warning must come *after* we fully set up the context
2809          * stuff so that __WARN__ handlers can safely dounwind()
2810          * if they want to
2811          */
2812         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2813             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2814             sub_crush_depth(cv);
2815 #if 0
2816         DEBUG_S(PerlIO_printf(Perl_debug_log,
2817                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2818 #endif
2819         RETURNOP(CvSTART(cv));
2820     }
2821 }
2822
2823 void
2824 Perl_sub_crush_depth(pTHX_ CV *cv)
2825 {
2826     if (CvANON(cv))
2827         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2828     else {
2829         SV* tmpstr = sv_newmortal();
2830         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2831         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2832                 SvPVX(tmpstr));
2833     }
2834 }
2835
2836 PP(pp_aelem)
2837 {
2838     djSP;
2839     SV** svp;
2840     SV* elemsv = POPs;
2841     IV elem = SvIV(elemsv);
2842     AV* av = (AV*)POPs;
2843     U32 lval = PL_op->op_flags & OPf_MOD;
2844     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2845     SV *sv;
2846
2847     if (SvROK(elemsv) && ckWARN(WARN_MISC))
2848         Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2849     if (elem > 0)
2850         elem -= PL_curcop->cop_arybase;
2851     if (SvTYPE(av) != SVt_PVAV)
2852         RETPUSHUNDEF;
2853     svp = av_fetch(av, elem, lval && !defer);
2854     if (lval) {
2855         if (!svp || *svp == &PL_sv_undef) {
2856             SV* lv;
2857             if (!defer)
2858                 DIE(aTHX_ PL_no_aelem, elem);
2859             lv = sv_newmortal();
2860             sv_upgrade(lv, SVt_PVLV);
2861             LvTYPE(lv) = 'y';
2862             sv_magic(lv, Nullsv, 'y', Nullch, 0);
2863             LvTARG(lv) = SvREFCNT_inc(av);
2864             LvTARGOFF(lv) = elem;
2865             LvTARGLEN(lv) = 1;
2866             PUSHs(lv);
2867             RETURN;
2868         }
2869         if (PL_op->op_private & OPpLVAL_INTRO)
2870             save_aelem(av, elem, svp);
2871         else if (PL_op->op_private & OPpDEREF)
2872             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2873     }
2874     sv = (svp ? *svp : &PL_sv_undef);
2875     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2876         sv = sv_mortalcopy(sv);
2877     PUSHs(sv);
2878     RETURN;
2879 }
2880
2881 void
2882 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2883 {
2884     if (SvGMAGICAL(sv))
2885         mg_get(sv);
2886     if (!SvOK(sv)) {
2887         if (SvREADONLY(sv))
2888             Perl_croak(aTHX_ PL_no_modify);
2889         if (SvTYPE(sv) < SVt_RV)
2890             sv_upgrade(sv, SVt_RV);
2891         else if (SvTYPE(sv) >= SVt_PV) {
2892             (void)SvOOK_off(sv);
2893             Safefree(SvPVX(sv));
2894             SvLEN(sv) = SvCUR(sv) = 0;
2895         }
2896         switch (to_what) {
2897         case OPpDEREF_SV:
2898             SvRV(sv) = NEWSV(355,0);
2899             break;
2900         case OPpDEREF_AV:
2901             SvRV(sv) = (SV*)newAV();
2902             break;
2903         case OPpDEREF_HV:
2904             SvRV(sv) = (SV*)newHV();
2905             break;
2906         }
2907         SvROK_on(sv);
2908         SvSETMAGIC(sv);
2909     }
2910 }
2911
2912 PP(pp_method)
2913 {
2914     djSP;
2915     SV* sv = TOPs;
2916
2917     if (SvROK(sv)) {
2918         SV* rsv = SvRV(sv);
2919         if (SvTYPE(rsv) == SVt_PVCV) {
2920             SETs(rsv);
2921             RETURN;
2922         }
2923     }
2924
2925     SETs(method_common(sv, Null(U32*)));
2926     RETURN;
2927 }
2928
2929 PP(pp_method_named)
2930 {
2931     djSP;
2932     SV* sv = cSVOP->op_sv;
2933     U32 hash = SvUVX(sv);
2934
2935     XPUSHs(method_common(sv, &hash));
2936     RETURN;
2937 }
2938
2939 STATIC SV *
2940 S_method_common(pTHX_ SV* meth, U32* hashp)
2941 {
2942     SV* sv;
2943     SV* ob;
2944     GV* gv;
2945     HV* stash;
2946     char* name;
2947     STRLEN namelen;
2948     char* packname;
2949     STRLEN packlen;
2950
2951     name = SvPV(meth, namelen);
2952     sv = *(PL_stack_base + TOPMARK + 1);
2953
2954     if (!sv)
2955         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2956
2957     if (SvGMAGICAL(sv))
2958         mg_get(sv);
2959     if (SvROK(sv))
2960         ob = (SV*)SvRV(sv);
2961     else {
2962         GV* iogv;
2963
2964         packname = Nullch;
2965         if (!SvOK(sv) ||
2966             !(packname = SvPV(sv, packlen)) ||
2967             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2968             !(ob=(SV*)GvIO(iogv)))
2969         {
2970             if (!packname ||
2971                 ((*(U8*)packname >= 0xc0 && DO_UTF8(sv))
2972                     ? !isIDFIRST_utf8((U8*)packname)
2973                     : !isIDFIRST(*packname)
2974                 ))
2975             {
2976                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
2977                            SvOK(sv) ? "without a package or object reference"
2978                                     : "on an undefined value");
2979             }
2980             stash = gv_stashpvn(packname, packlen, TRUE);
2981             goto fetch;
2982         }
2983         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2984     }
2985
2986     if (!ob || !(SvOBJECT(ob)
2987                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
2988                      && SvOBJECT(ob))))
2989     {
2990         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
2991                    name);
2992     }
2993
2994     stash = SvSTASH(ob);
2995
2996   fetch:
2997     /* shortcut for simple names */
2998     if (hashp) {
2999         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3000         if (he) {
3001             gv = (GV*)HeVAL(he);
3002             if (isGV(gv) && GvCV(gv) &&
3003                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3004                 return (SV*)GvCV(gv);
3005         }
3006     }
3007
3008     gv = gv_fetchmethod(stash, name);
3009     if (!gv) {
3010         char* leaf = name;
3011         char* sep = Nullch;
3012         char* p;
3013         GV* gv;
3014
3015         for (p = name; *p; p++) {
3016             if (*p == '\'')
3017                 sep = p, leaf = p + 1;
3018             else if (*p == ':' && *(p + 1) == ':')
3019                 sep = p, leaf = p + 2;
3020         }
3021         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3022             packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3023             packlen = strlen(packname);
3024         }
3025         else {
3026             packname = name;
3027             packlen = sep - name;
3028         }
3029         gv = gv_fetchpv(packname, 0, SVt_PVHV);
3030         if (gv && isGV(gv)) {
3031             Perl_croak(aTHX_
3032                        "Can't locate object method \"%s\" via package \"%s\"",
3033                        leaf, packname);
3034         }
3035         else {
3036             Perl_croak(aTHX_
3037                        "Can't locate object method \"%s\" via package \"%s\""
3038                        " (perhaps you forgot to load \"%s\"?)",
3039                        leaf, packname, packname);
3040         }
3041     }
3042     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3043 }
3044
3045 #ifdef USE_THREADS
3046 static void
3047 unset_cvowner(pTHXo_ void *cvarg)
3048 {
3049     register CV* cv = (CV *) cvarg;
3050
3051     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3052                            thr, cv, SvPEEK((SV*)cv))));
3053     MUTEX_LOCK(CvMUTEXP(cv));
3054     DEBUG_S(if (CvDEPTH(cv) != 0)
3055                 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3056                               CvDEPTH(cv)););
3057     assert(thr == CvOWNER(cv));
3058     CvOWNER(cv) = 0;
3059     MUTEX_UNLOCK(CvMUTEXP(cv));
3060     SvREFCNT_dec(cv);
3061 }
3062 #endif /* USE_THREADS */