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