This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0bcb7bde250c4810aa7070abf10f7c3e01c6e6b0
[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 UTF-8 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     I32 gimme = GIMME_V;
799
800     if (SvROK(sv)) {
801       wasref:
802         tryAMAGICunDEREF(to_hv);
803
804         hv = (HV*)SvRV(sv);
805         if (SvTYPE(hv) != SVt_PVHV)
806             DIE(aTHX_ "Not a HASH reference");
807         if (PL_op->op_flags & OPf_REF) {
808             SETs((SV*)hv);
809             RETURN;
810         }
811         else if (LVRET) {
812             if (gimme != G_ARRAY)
813                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
814             SETs((SV*)hv);
815             RETURN;
816         }
817         else if (PL_op->op_flags & OPf_MOD
818                 && PL_op->op_private & OPpLVAL_INTRO)
819             Perl_croak(aTHX_ PL_no_localize_ref);
820     }
821     else {
822         if (SvTYPE(sv) == SVt_PVHV) {
823             hv = (HV*)sv;
824             if (PL_op->op_flags & OPf_REF) {
825                 SETs((SV*)hv);
826                 RETURN;
827             }
828             else if (LVRET) {
829                 if (gimme != G_ARRAY)
830                     Perl_croak(aTHX_ "Can't return hash to lvalue"
831                                " scalar context");
832                 SETs((SV*)hv);
833                 RETURN;
834             }
835         }
836         else {
837             GV *gv;
838         
839             if (SvTYPE(sv) != SVt_PVGV) {
840                 char *sym;
841                 STRLEN len;
842
843                 if (SvGMAGICAL(sv)) {
844                     mg_get(sv);
845                     if (SvROK(sv))
846                         goto wasref;
847                 }
848                 if (!SvOK(sv)) {
849                     if (PL_op->op_flags & OPf_REF ||
850                       PL_op->op_private & HINT_STRICT_REFS)
851                         DIE(aTHX_ PL_no_usym, "a HASH");
852                     if (ckWARN(WARN_UNINITIALIZED))
853                         report_uninit();
854                     if (gimme == G_ARRAY) {
855                         SP--;
856                         RETURN;
857                     }
858                     RETSETUNDEF;
859                 }
860                 sym = SvPV(sv,len);
861                 if ((PL_op->op_flags & OPf_SPECIAL) &&
862                     !(PL_op->op_flags & OPf_MOD))
863                 {
864                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
865                     if (!gv
866                         && (!is_gv_magical(sym,len,0)
867                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
868                     {
869                         RETSETUNDEF;
870                     }
871                 }
872                 else {
873                     if (PL_op->op_private & HINT_STRICT_REFS)
874                         DIE(aTHX_ PL_no_symref, sym, "a HASH");
875                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
876                 }
877             }
878             else {
879                 gv = (GV*)sv;
880             }
881             hv = GvHVn(gv);
882             if (PL_op->op_private & OPpLVAL_INTRO)
883                 hv = save_hash(gv);
884             if (PL_op->op_flags & OPf_REF) {
885                 SETs((SV*)hv);
886                 RETURN;
887             }
888             else if (LVRET) {
889                 if (gimme != G_ARRAY)
890                     Perl_croak(aTHX_ "Can't return hash to lvalue"
891                                " scalar context");
892                 SETs((SV*)hv);
893                 RETURN;
894             }
895         }
896     }
897
898     if (gimme == G_ARRAY) { /* array wanted */
899         *PL_stack_sp = (SV*)hv;
900         return do_kv();
901     }
902     else if (gimme == G_SCALAR) {
903         dTARGET;
904         if (SvRMAGICAL(hv) && mg_find((SV *)hv, PERL_MAGIC_tied))
905             Perl_croak(aTHX_ "Can't provide tied hash usage; "
906                        "use keys(%%hash) to test if empty");
907         if (HvFILL(hv))
908             Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
909                            (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
910         else
911             sv_setiv(TARG, 0);
912         
913         SETTARG;
914     }
915     RETURN;
916 }
917
918 STATIC void
919 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
920 {
921     if (*relem) {
922         SV *tmpstr;
923         HE *didstore;
924
925         if (ckWARN(WARN_MISC)) {
926             if (relem == firstrelem &&
927                 SvROK(*relem) &&
928                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
929                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
930             {
931                 Perl_warner(aTHX_ packWARN(WARN_MISC),
932                             "Reference found where even-sized list expected");
933             }
934             else
935                 Perl_warner(aTHX_ packWARN(WARN_MISC),
936                             "Odd number of elements in hash assignment");
937         }
938
939         tmpstr = NEWSV(29,0);
940         didstore = hv_store_ent(hash,*relem,tmpstr,0);
941         if (SvMAGICAL(hash)) {
942             if (SvSMAGICAL(tmpstr))
943                 mg_set(tmpstr);
944             if (!didstore)
945                 sv_2mortal(tmpstr);
946         }
947         TAINT_NOT;
948     }
949 }
950
951 PP(pp_aassign)
952 {
953     dSP;
954     SV **lastlelem = PL_stack_sp;
955     SV **lastrelem = PL_stack_base + POPMARK;
956     SV **firstrelem = PL_stack_base + POPMARK + 1;
957     SV **firstlelem = lastrelem + 1;
958
959     register SV **relem;
960     register SV **lelem;
961
962     register SV *sv;
963     register AV *ary;
964
965     I32 gimme;
966     HV *hash;
967     I32 i;
968     int magic;
969     int duplicates = 0;
970     SV **firsthashrelem;
971
972     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
973     gimme = GIMME_V;
974
975     /* If there's a common identifier on both sides we have to take
976      * special care that assigning the identifier on the left doesn't
977      * clobber a value on the right that's used later in the list.
978      */
979     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
980         EXTEND_MORTAL(lastrelem - firstrelem + 1);
981         for (relem = firstrelem; relem <= lastrelem; relem++) {
982             /*SUPPRESS 560*/
983             if ((sv = *relem)) {
984                 TAINT_NOT;      /* Each item is independent */
985                 *relem = sv_mortalcopy(sv);
986             }
987         }
988     }
989
990     relem = firstrelem;
991     lelem = firstlelem;
992     ary = Null(AV*);
993     hash = Null(HV*);
994
995     while (lelem <= lastlelem) {
996         TAINT_NOT;              /* Each item stands on its own, taintwise. */
997         sv = *lelem++;
998         switch (SvTYPE(sv)) {
999         case SVt_PVAV:
1000             ary = (AV*)sv;
1001             magic = SvMAGICAL(ary) != 0;
1002             av_clear(ary);
1003             av_extend(ary, lastrelem - relem);
1004             i = 0;
1005             while (relem <= lastrelem) {        /* gobble up all the rest */
1006                 SV **didstore;
1007                 sv = NEWSV(28,0);
1008                 assert(*relem);
1009                 sv_setsv(sv,*relem);
1010                 *(relem++) = sv;
1011                 didstore = av_store(ary,i++,sv);
1012                 if (magic) {
1013                     if (SvSMAGICAL(sv))
1014                         mg_set(sv);
1015                     if (!didstore)
1016                         sv_2mortal(sv);
1017                 }
1018                 TAINT_NOT;
1019             }
1020             break;
1021         case SVt_PVHV: {                                /* normal hash */
1022                 SV *tmpstr;
1023
1024                 hash = (HV*)sv;
1025                 magic = SvMAGICAL(hash) != 0;
1026                 hv_clear(hash);
1027                 firsthashrelem = relem;
1028
1029                 while (relem < lastrelem) {     /* gobble up all the rest */
1030                     HE *didstore;
1031                     if (*relem)
1032                         sv = *(relem++);
1033                     else
1034                         sv = &PL_sv_no, relem++;
1035                     tmpstr = NEWSV(29,0);
1036                     if (*relem)
1037                         sv_setsv(tmpstr,*relem);        /* value */
1038                     *(relem++) = tmpstr;
1039                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1040                         /* key overwrites an existing entry */
1041                         duplicates += 2;
1042                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1043                     if (magic) {
1044                         if (SvSMAGICAL(tmpstr))
1045                             mg_set(tmpstr);
1046                         if (!didstore)
1047                             sv_2mortal(tmpstr);
1048                     }
1049                     TAINT_NOT;
1050                 }
1051                 if (relem == lastrelem) {
1052                     do_oddball(hash, relem, firstrelem);
1053                     relem++;
1054                 }
1055             }
1056             break;
1057         default:
1058             if (SvIMMORTAL(sv)) {
1059                 if (relem <= lastrelem)
1060                     relem++;
1061                 break;
1062             }
1063             if (relem <= lastrelem) {
1064                 sv_setsv(sv, *relem);
1065                 *(relem++) = sv;
1066             }
1067             else
1068                 sv_setsv(sv, &PL_sv_undef);
1069             SvSETMAGIC(sv);
1070             break;
1071         }
1072     }
1073     if (PL_delaymagic & ~DM_DELAY) {
1074         if (PL_delaymagic & DM_UID) {
1075 #ifdef HAS_SETRESUID
1076             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1077                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1078                             (Uid_t)-1);
1079 #else
1080 #  ifdef HAS_SETREUID
1081             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1082                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1083 #  else
1084 #    ifdef HAS_SETRUID
1085             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1086                 (void)setruid(PL_uid);
1087                 PL_delaymagic &= ~DM_RUID;
1088             }
1089 #    endif /* HAS_SETRUID */
1090 #    ifdef HAS_SETEUID
1091             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1092                 (void)seteuid(PL_euid);
1093                 PL_delaymagic &= ~DM_EUID;
1094             }
1095 #    endif /* HAS_SETEUID */
1096             if (PL_delaymagic & DM_UID) {
1097                 if (PL_uid != PL_euid)
1098                     DIE(aTHX_ "No setreuid available");
1099                 (void)PerlProc_setuid(PL_uid);
1100             }
1101 #  endif /* HAS_SETREUID */
1102 #endif /* HAS_SETRESUID */
1103             PL_uid = PerlProc_getuid();
1104             PL_euid = PerlProc_geteuid();
1105         }
1106         if (PL_delaymagic & DM_GID) {
1107 #ifdef HAS_SETRESGID
1108             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1109                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1110                             (Gid_t)-1);
1111 #else
1112 #  ifdef HAS_SETREGID
1113             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1114                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1115 #  else
1116 #    ifdef HAS_SETRGID
1117             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1118                 (void)setrgid(PL_gid);
1119                 PL_delaymagic &= ~DM_RGID;
1120             }
1121 #    endif /* HAS_SETRGID */
1122 #    ifdef HAS_SETEGID
1123             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1124                 (void)setegid(PL_egid);
1125                 PL_delaymagic &= ~DM_EGID;
1126             }
1127 #    endif /* HAS_SETEGID */
1128             if (PL_delaymagic & DM_GID) {
1129                 if (PL_gid != PL_egid)
1130                     DIE(aTHX_ "No setregid available");
1131                 (void)PerlProc_setgid(PL_gid);
1132             }
1133 #  endif /* HAS_SETREGID */
1134 #endif /* HAS_SETRESGID */
1135             PL_gid = PerlProc_getgid();
1136             PL_egid = PerlProc_getegid();
1137         }
1138         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1139     }
1140     PL_delaymagic = 0;
1141
1142     if (gimme == G_VOID)
1143         SP = firstrelem - 1;
1144     else if (gimme == G_SCALAR) {
1145         dTARGET;
1146         SP = firstrelem;
1147         SETi(lastrelem - firstrelem + 1 - duplicates);
1148     }
1149     else {
1150         if (ary)
1151             SP = lastrelem;
1152         else if (hash) {
1153             if (duplicates) {
1154                 /* Removes from the stack the entries which ended up as
1155                  * duplicated keys in the hash (fix for [perl #24380]) */
1156                 Move(firsthashrelem + duplicates,
1157                         firsthashrelem, duplicates, SV**);
1158                 lastrelem -= duplicates;
1159             }
1160             SP = lastrelem;
1161         }
1162         else
1163             SP = firstrelem + (lastlelem - firstlelem);
1164         lelem = firstlelem + (relem - firstrelem);
1165         while (relem <= SP)
1166             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1167     }
1168     RETURN;
1169 }
1170
1171 PP(pp_qr)
1172 {
1173     dSP;
1174     register PMOP *pm = cPMOP;
1175     SV *rv = sv_newmortal();
1176     SV *sv = newSVrv(rv, "Regexp");
1177     if (pm->op_pmdynflags & PMdf_TAINTED)
1178         SvTAINTED_on(rv);
1179     sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1180     RETURNX(PUSHs(rv));
1181 }
1182
1183 PP(pp_match)
1184 {
1185     dSP; dTARG;
1186     register PMOP *pm = cPMOP;
1187     PMOP *dynpm = pm;
1188     register char *t;
1189     register char *s;
1190     char *strend;
1191     I32 global;
1192     I32 r_flags = REXEC_CHECKED;
1193     char *truebase;                     /* Start of string  */
1194     register REGEXP *rx = PM_GETRE(pm);
1195     bool rxtainted;
1196     I32 gimme = GIMME;
1197     STRLEN len;
1198     I32 minmatch = 0;
1199     I32 oldsave = PL_savestack_ix;
1200     I32 update_minmatch = 1;
1201     I32 had_zerolen = 0;
1202
1203     if (PL_op->op_flags & OPf_STACKED)
1204         TARG = POPs;
1205     else {
1206         TARG = DEFSV;
1207         EXTEND(SP,1);
1208     }
1209
1210     PUTBACK;                            /* EVAL blocks need stack_sp. */
1211     s = SvPV(TARG, len);
1212     strend = s + len;
1213     if (!s)
1214         DIE(aTHX_ "panic: pp_match");
1215     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1216                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1217     TAINT_NOT;
1218
1219     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1220
1221     /* PMdf_USED is set after a ?? matches once */
1222     if (pm->op_pmdynflags & PMdf_USED) {
1223       failure:
1224         if (gimme == G_ARRAY)
1225             RETURN;
1226         RETPUSHNO;
1227     }
1228
1229     /* empty pattern special-cased to use last successful pattern if possible */
1230     if (!rx->prelen && PL_curpm) {
1231         pm = PL_curpm;
1232         rx = PM_GETRE(pm);
1233     }
1234
1235     if (rx->minlen > (I32)len)
1236         goto failure;
1237
1238     truebase = t = s;
1239
1240     /* XXXX What part of this is needed with true \G-support? */
1241     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1242         rx->startp[0] = -1;
1243         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1244             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1245             if (mg && mg->mg_len >= 0) {
1246                 if (!(rx->reganch & ROPT_GPOS_SEEN))
1247                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1248                 else if (rx->reganch & ROPT_ANCH_GPOS) {
1249                     r_flags |= REXEC_IGNOREPOS;
1250                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1251                 }
1252                 minmatch = (mg->mg_flags & MGf_MINMATCH);
1253                 update_minmatch = 0;
1254             }
1255         }
1256     }
1257     if ((!global && rx->nparens)
1258             || SvTEMP(TARG) || PL_sawampersand)
1259         r_flags |= REXEC_COPY_STR;
1260     if (SvSCREAM(TARG))
1261         r_flags |= REXEC_SCREAM;
1262
1263     if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1264         SAVEINT(PL_multiline);
1265         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1266     }
1267
1268 play_it_again:
1269     if (global && rx->startp[0] != -1) {
1270         t = s = rx->endp[0] + truebase;
1271         if ((s + rx->minlen) > strend)
1272             goto nope;
1273         if (update_minmatch++)
1274             minmatch = had_zerolen;
1275     }
1276     if (rx->reganch & RE_USE_INTUIT &&
1277         DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1278         PL_bostr = truebase;
1279         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1280
1281         if (!s)
1282             goto nope;
1283         if ( (rx->reganch & ROPT_CHECK_ALL)
1284              && !PL_sawampersand
1285              && ((rx->reganch & ROPT_NOSCAN)
1286                  || !((rx->reganch & RE_INTUIT_TAIL)
1287                       && (r_flags & REXEC_SCREAM)))
1288              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1289             goto yup;
1290     }
1291     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1292     {
1293         PL_curpm = pm;
1294         if (dynpm->op_pmflags & PMf_ONCE)
1295             dynpm->op_pmdynflags |= PMdf_USED;
1296         goto gotcha;
1297     }
1298     else
1299         goto ret_no;
1300     /*NOTREACHED*/
1301
1302   gotcha:
1303     if (rxtainted)
1304         RX_MATCH_TAINTED_on(rx);
1305     TAINT_IF(RX_MATCH_TAINTED(rx));
1306     if (gimme == G_ARRAY) {
1307         I32 nparens, i, len;
1308
1309         nparens = rx->nparens;
1310         if (global && !nparens)
1311             i = 1;
1312         else
1313             i = 0;
1314         SPAGAIN;                        /* EVAL blocks could move the stack. */
1315         EXTEND(SP, nparens + i);
1316         EXTEND_MORTAL(nparens + i);
1317         for (i = !i; i <= nparens; i++) {
1318             PUSHs(sv_newmortal());
1319             /*SUPPRESS 560*/
1320             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1321                 len = rx->endp[i] - rx->startp[i];
1322                 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1323                     len < 0 || len > strend - s)
1324                     DIE(aTHX_ "panic: pp_match start/end pointers");
1325                 s = rx->startp[i] + truebase;
1326                 sv_setpvn(*SP, s, len);
1327                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1328                     SvUTF8_on(*SP);
1329             }
1330         }
1331         if (global) {
1332             if (dynpm->op_pmflags & PMf_CONTINUE) {
1333                 MAGIC* mg = 0;
1334                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1335                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1336                 if (!mg) {
1337                     sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1338                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1339                 }
1340                 if (rx->startp[0] != -1) {
1341                     mg->mg_len = rx->endp[0];
1342                     if (rx->startp[0] == rx->endp[0])
1343                         mg->mg_flags |= MGf_MINMATCH;
1344                     else
1345                         mg->mg_flags &= ~MGf_MINMATCH;
1346                 }
1347             }
1348             had_zerolen = (rx->startp[0] != -1
1349                            && rx->startp[0] == rx->endp[0]);
1350             PUTBACK;                    /* EVAL blocks may use stack */
1351             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1352             goto play_it_again;
1353         }
1354         else if (!nparens)
1355             XPUSHs(&PL_sv_yes);
1356         LEAVE_SCOPE(oldsave);
1357         RETURN;
1358     }
1359     else {
1360         if (global) {
1361             MAGIC* mg = 0;
1362             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1363                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1364             if (!mg) {
1365                 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1366                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1367             }
1368             if (rx->startp[0] != -1) {
1369                 mg->mg_len = rx->endp[0];
1370                 if (rx->startp[0] == rx->endp[0])
1371                     mg->mg_flags |= MGf_MINMATCH;
1372                 else
1373                     mg->mg_flags &= ~MGf_MINMATCH;
1374             }
1375         }
1376         LEAVE_SCOPE(oldsave);
1377         RETPUSHYES;
1378     }
1379
1380 yup:                                    /* Confirmed by INTUIT */
1381     if (rxtainted)
1382         RX_MATCH_TAINTED_on(rx);
1383     TAINT_IF(RX_MATCH_TAINTED(rx));
1384     PL_curpm = pm;
1385     if (dynpm->op_pmflags & PMf_ONCE)
1386         dynpm->op_pmdynflags |= PMdf_USED;
1387     if (RX_MATCH_COPIED(rx))
1388         Safefree(rx->subbeg);
1389     RX_MATCH_COPIED_off(rx);
1390     rx->subbeg = Nullch;
1391     if (global) {
1392         rx->subbeg = truebase;
1393         rx->startp[0] = s - truebase;
1394         if (RX_MATCH_UTF8(rx)) {
1395             char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1396             rx->endp[0] = t - truebase;
1397         }
1398         else {
1399             rx->endp[0] = s - truebase + rx->minlen;
1400         }
1401         rx->sublen = strend - truebase;
1402         goto gotcha;
1403     }
1404     if (PL_sawampersand) {
1405         I32 off;
1406 #ifdef PERL_COPY_ON_WRITE
1407         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1408             if (DEBUG_C_TEST) {
1409                 PerlIO_printf(Perl_debug_log,
1410                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1411                               (int) SvTYPE(TARG), truebase, t,
1412                               (int)(t-truebase));
1413             }
1414             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1415             rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1416             assert (SvPOKp(rx->saved_copy));
1417         } else
1418 #endif
1419         {
1420
1421             rx->subbeg = savepvn(t, strend - t);
1422 #ifdef PERL_COPY_ON_WRITE
1423             rx->saved_copy = Nullsv;
1424 #endif
1425         }
1426         rx->sublen = strend - t;
1427         RX_MATCH_COPIED_on(rx);
1428         off = rx->startp[0] = s - t;
1429         rx->endp[0] = off + rx->minlen;
1430     }
1431     else {                      /* startp/endp are used by @- @+. */
1432         rx->startp[0] = s - truebase;
1433         rx->endp[0] = s - truebase + rx->minlen;
1434     }
1435     rx->nparens = rx->lastparen = rx->lastcloseparen = 0;       /* used by @-, @+, and $^N */
1436     LEAVE_SCOPE(oldsave);
1437     RETPUSHYES;
1438
1439 nope:
1440 ret_no:
1441     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1442         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1443             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1444             if (mg)
1445                 mg->mg_len = -1;
1446         }
1447     }
1448     LEAVE_SCOPE(oldsave);
1449     if (gimme == G_ARRAY)
1450         RETURN;
1451     RETPUSHNO;
1452 }
1453
1454 OP *
1455 Perl_do_readline(pTHX)
1456 {
1457     dSP; dTARGETSTACKED;
1458     register SV *sv;
1459     STRLEN tmplen = 0;
1460     STRLEN offset;
1461     PerlIO *fp;
1462     register IO *io = GvIO(PL_last_in_gv);
1463     register I32 type = PL_op->op_type;
1464     I32 gimme = GIMME_V;
1465     MAGIC *mg;
1466
1467     if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1468         PUSHMARK(SP);
1469         XPUSHs(SvTIED_obj((SV*)io, mg));
1470         PUTBACK;
1471         ENTER;
1472         call_method("READLINE", gimme);
1473         LEAVE;
1474         SPAGAIN;
1475         if (gimme == G_SCALAR) {
1476             SV* result = POPs;
1477             SvSetSV_nosteal(TARG, result);
1478             PUSHTARG;
1479         }
1480         RETURN;
1481     }
1482     fp = Nullfp;
1483     if (io) {
1484         fp = IoIFP(io);
1485         if (!fp) {
1486             if (IoFLAGS(io) & IOf_ARGV) {
1487                 if (IoFLAGS(io) & IOf_START) {
1488                     IoLINES(io) = 0;
1489                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1490                         IoFLAGS(io) &= ~IOf_START;
1491                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1492                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1493                         SvSETMAGIC(GvSV(PL_last_in_gv));
1494                         fp = IoIFP(io);
1495                         goto have_fp;
1496                     }
1497                 }
1498                 fp = nextargv(PL_last_in_gv);
1499                 if (!fp) { /* Note: fp != IoIFP(io) */
1500                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1501                 }
1502             }
1503             else if (type == OP_GLOB)
1504                 fp = Perl_start_glob(aTHX_ POPs, io);
1505         }
1506         else if (type == OP_GLOB)
1507             SP--;
1508         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1509             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1510         }
1511     }
1512     if (!fp) {
1513         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1514                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1515             if (type == OP_GLOB)
1516                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1517                             "glob failed (can't start child: %s)",
1518                             Strerror(errno));
1519             else
1520                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1521         }
1522         if (gimme == G_SCALAR) {
1523             /* undef TARG, and push that undefined value */
1524             if (type != OP_RCATLINE) {
1525                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1526                 (void)SvOK_off(TARG);
1527             }
1528             PUSHTARG;
1529         }
1530         RETURN;
1531     }
1532   have_fp:
1533     if (gimme == G_SCALAR) {
1534         sv = TARG;
1535         if (SvROK(sv))
1536             sv_unref(sv);
1537         (void)SvUPGRADE(sv, SVt_PV);
1538         tmplen = SvLEN(sv);     /* remember if already alloced */
1539         if (!tmplen && !SvREADONLY(sv))
1540             Sv_Grow(sv, 80);    /* try short-buffering it */
1541         offset = 0;
1542         if (type == OP_RCATLINE && SvOK(sv)) {
1543             if (!SvPOK(sv)) {
1544                 STRLEN n_a;
1545                 (void)SvPV_force(sv, n_a);
1546             }
1547             offset = SvCUR(sv);
1548         }
1549     }
1550     else {
1551         sv = sv_2mortal(NEWSV(57, 80));
1552         offset = 0;
1553     }
1554
1555     /* This should not be marked tainted if the fp is marked clean */
1556 #define MAYBE_TAINT_LINE(io, sv) \
1557     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1558         TAINT;                          \
1559         SvTAINTED_on(sv);               \
1560     }
1561
1562 /* delay EOF state for a snarfed empty file */
1563 #define SNARF_EOF(gimme,rs,io,sv) \
1564     (gimme != G_SCALAR || SvCUR(sv)                                     \
1565      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1566
1567     for (;;) {
1568         PUTBACK;
1569         if (!sv_gets(sv, fp, offset)
1570             && (type == OP_GLOB
1571                 || SNARF_EOF(gimme, PL_rs, io, sv)
1572                 || PerlIO_error(fp)))
1573         {
1574             PerlIO_clearerr(fp);
1575             if (IoFLAGS(io) & IOf_ARGV) {
1576                 fp = nextargv(PL_last_in_gv);
1577                 if (fp)
1578                     continue;
1579                 (void)do_close(PL_last_in_gv, FALSE);
1580             }
1581             else if (type == OP_GLOB) {
1582                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1583                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1584                            "glob failed (child exited with status %d%s)",
1585                            (int)(STATUS_CURRENT >> 8),
1586                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1587                 }
1588             }
1589             if (gimme == G_SCALAR) {
1590                 if (type != OP_RCATLINE) {
1591                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1592                     (void)SvOK_off(TARG);
1593                 }
1594                 SPAGAIN;
1595                 PUSHTARG;
1596             }
1597             MAYBE_TAINT_LINE(io, sv);
1598             RETURN;
1599         }
1600         MAYBE_TAINT_LINE(io, sv);
1601         IoLINES(io)++;
1602         IoFLAGS(io) |= IOf_NOLINE;
1603         SvSETMAGIC(sv);
1604         SPAGAIN;
1605         XPUSHs(sv);
1606         if (type == OP_GLOB) {
1607             char *tmps;
1608
1609             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1610                 tmps = SvEND(sv) - 1;
1611                 if (*tmps == *SvPVX(PL_rs)) {
1612                     *tmps = '\0';
1613                     SvCUR(sv)--;
1614                 }
1615             }
1616             for (tmps = SvPVX(sv); *tmps; tmps++)
1617                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1618                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1619                         break;
1620             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1621                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1622                 continue;
1623             }
1624         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1625              U8 *s = (U8*)SvPVX(sv) + offset;
1626              STRLEN len = SvCUR(sv) - offset;
1627              U8 *f;
1628              
1629              if (ckWARN(WARN_UTF8) &&
1630                  !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1631                   /* Emulate :encoding(utf8) warning in the same case. */
1632                   Perl_warner(aTHX_ packWARN(WARN_UTF8),
1633                               "utf8 \"\\x%02X\" does not map to Unicode",
1634                               f < (U8*)SvEND(sv) ? *f : 0);
1635         }
1636         if (gimme == G_ARRAY) {
1637             if (SvLEN(sv) - SvCUR(sv) > 20) {
1638                 SvLEN_set(sv, SvCUR(sv)+1);
1639                 Renew(SvPVX(sv), SvLEN(sv), char);
1640             }
1641             sv = sv_2mortal(NEWSV(58, 80));
1642             continue;
1643         }
1644         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1645             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1646             if (SvCUR(sv) < 60)
1647                 SvLEN_set(sv, 80);
1648             else
1649                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1650             Renew(SvPVX(sv), SvLEN(sv), char);
1651         }
1652         RETURN;
1653     }
1654 }
1655
1656 PP(pp_enter)
1657 {
1658     dSP;
1659     register PERL_CONTEXT *cx;
1660     I32 gimme = OP_GIMME(PL_op, -1);
1661
1662     if (gimme == -1) {
1663         if (cxstack_ix >= 0)
1664             gimme = cxstack[cxstack_ix].blk_gimme;
1665         else
1666             gimme = G_SCALAR;
1667     }
1668
1669     ENTER;
1670
1671     SAVETMPS;
1672     PUSHBLOCK(cx, CXt_BLOCK, SP);
1673
1674     RETURN;
1675 }
1676
1677 PP(pp_helem)
1678 {
1679     dSP;
1680     HE* he;
1681     SV **svp;
1682     SV *keysv = POPs;
1683     HV *hv = (HV*)POPs;
1684     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1685     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1686     SV *sv;
1687 #ifdef PERL_COPY_ON_WRITE
1688     U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1689 #else
1690     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1691 #endif
1692     I32 preeminent = 0;
1693
1694     if (SvTYPE(hv) == SVt_PVHV) {
1695         if (PL_op->op_private & OPpLVAL_INTRO) {
1696             MAGIC *mg;
1697             HV *stash;
1698             /* does the element we're localizing already exist? */
1699             preeminent =  
1700                 /* can we determine whether it exists? */
1701                 (    !SvRMAGICAL(hv)
1702                   || mg_find((SV*)hv, PERL_MAGIC_env)
1703                   || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1704                         /* Try to preserve the existenceness of a tied hash
1705                          * element by using EXISTS and DELETE if possible.
1706                          * Fallback to FETCH and STORE otherwise */
1707                         && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1708                         && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1709                         && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1710                     )
1711                 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1712
1713         }
1714         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1715         svp = he ? &HeVAL(he) : 0;
1716     }
1717     else {
1718         RETPUSHUNDEF;
1719     }
1720     if (lval) {
1721         if (!svp || *svp == &PL_sv_undef) {
1722             SV* lv;
1723             SV* key2;
1724             if (!defer) {
1725                 STRLEN n_a;
1726                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1727             }
1728             lv = sv_newmortal();
1729             sv_upgrade(lv, SVt_PVLV);
1730             LvTYPE(lv) = 'y';
1731             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1732             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1733             LvTARG(lv) = SvREFCNT_inc(hv);
1734             LvTARGLEN(lv) = 1;
1735             PUSHs(lv);
1736             RETURN;
1737         }
1738         if (PL_op->op_private & OPpLVAL_INTRO) {
1739             if (HvNAME(hv) && isGV(*svp))
1740                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1741             else {
1742                 if (!preeminent) {
1743                     STRLEN keylen;
1744                     char *key = SvPV(keysv, keylen);
1745                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1746                 } else
1747                     save_helem(hv, keysv, svp);
1748             }
1749         }
1750         else if (PL_op->op_private & OPpDEREF)
1751             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1752     }
1753     sv = (svp ? *svp : &PL_sv_undef);
1754     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1755      * Pushing the magical RHS on to the stack is useless, since
1756      * that magic is soon destined to be misled by the local(),
1757      * and thus the later pp_sassign() will fail to mg_get() the
1758      * old value.  This should also cure problems with delayed
1759      * mg_get()s.  GSAR 98-07-03 */
1760     if (!lval && SvGMAGICAL(sv))
1761         sv = sv_mortalcopy(sv);
1762     PUSHs(sv);
1763     RETURN;
1764 }
1765
1766 PP(pp_leave)
1767 {
1768     dSP;
1769     register PERL_CONTEXT *cx;
1770     register SV **mark;
1771     SV **newsp;
1772     PMOP *newpm;
1773     I32 gimme;
1774
1775     if (PL_op->op_flags & OPf_SPECIAL) {
1776         cx = &cxstack[cxstack_ix];
1777         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1778     }
1779
1780     POPBLOCK(cx,newpm);
1781
1782     gimme = OP_GIMME(PL_op, -1);
1783     if (gimme == -1) {
1784         if (cxstack_ix >= 0)
1785             gimme = cxstack[cxstack_ix].blk_gimme;
1786         else
1787             gimme = G_SCALAR;
1788     }
1789
1790     TAINT_NOT;
1791     if (gimme == G_VOID)
1792         SP = newsp;
1793     else if (gimme == G_SCALAR) {
1794         MARK = newsp + 1;
1795         if (MARK <= SP) {
1796             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1797                 *MARK = TOPs;
1798             else
1799                 *MARK = sv_mortalcopy(TOPs);
1800         } else {
1801             MEXTEND(mark,0);
1802             *MARK = &PL_sv_undef;
1803         }
1804         SP = MARK;
1805     }
1806     else if (gimme == G_ARRAY) {
1807         /* in case LEAVE wipes old return values */
1808         for (mark = newsp + 1; mark <= SP; mark++) {
1809             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1810                 *mark = sv_mortalcopy(*mark);
1811                 TAINT_NOT;      /* Each item is independent */
1812             }
1813         }
1814     }
1815     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1816
1817     LEAVE;
1818
1819     RETURN;
1820 }
1821
1822 PP(pp_iter)
1823 {
1824     dSP;
1825     register PERL_CONTEXT *cx;
1826     SV* sv;
1827     AV* av;
1828     SV **itersvp;
1829
1830     EXTEND(SP, 1);
1831     cx = &cxstack[cxstack_ix];
1832     if (CxTYPE(cx) != CXt_LOOP)
1833         DIE(aTHX_ "panic: pp_iter");
1834
1835     itersvp = CxITERVAR(cx);
1836     av = cx->blk_loop.iterary;
1837     if (SvTYPE(av) != SVt_PVAV) {
1838         /* iterate ($min .. $max) */
1839         if (cx->blk_loop.iterlval) {
1840             /* string increment */
1841             register SV* cur = cx->blk_loop.iterlval;
1842             STRLEN maxlen;
1843             char *max = SvPV((SV*)av, maxlen);
1844             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1845                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1846                     /* safe to reuse old SV */
1847                     sv_setsv(*itersvp, cur);
1848                 }
1849                 else
1850                 {
1851                     /* we need a fresh SV every time so that loop body sees a
1852                      * completely new SV for closures/references to work as
1853                      * they used to */
1854                     SvREFCNT_dec(*itersvp);
1855                     *itersvp = newSVsv(cur);
1856                 }
1857                 if (strEQ(SvPVX(cur), max))
1858                     sv_setiv(cur, 0); /* terminate next time */
1859                 else
1860                     sv_inc(cur);
1861                 RETPUSHYES;
1862             }
1863             RETPUSHNO;
1864         }
1865         /* integer increment */
1866         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1867             RETPUSHNO;
1868
1869         /* don't risk potential race */
1870         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1871             /* safe to reuse old SV */
1872             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1873         }
1874         else
1875         {
1876             /* we need a fresh SV every time so that loop body sees a
1877              * completely new SV for closures/references to work as they
1878              * used to */
1879             SvREFCNT_dec(*itersvp);
1880             *itersvp = newSViv(cx->blk_loop.iterix++);
1881         }
1882         RETPUSHYES;
1883     }
1884
1885     /* iterate array */
1886     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1887         RETPUSHNO;
1888
1889     SvREFCNT_dec(*itersvp);
1890
1891     if (SvMAGICAL(av) || AvREIFY(av)) {
1892         SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1893         if (svp)
1894             sv = *svp;
1895         else
1896             sv = Nullsv;
1897     }
1898     else {
1899         sv = AvARRAY(av)[++cx->blk_loop.iterix];
1900     }
1901     if (sv && SvREFCNT(sv) == 0) {
1902         *itersvp = Nullsv;
1903         Perl_croak(aTHX_ "Use of freed value in iteration");
1904     }
1905
1906     if (sv)
1907         SvTEMP_off(sv);
1908     else
1909         sv = &PL_sv_undef;
1910     if (av != PL_curstack && sv == &PL_sv_undef) {
1911         SV *lv = cx->blk_loop.iterlval;
1912         if (lv && SvREFCNT(lv) > 1) {
1913             SvREFCNT_dec(lv);
1914             lv = Nullsv;
1915         }
1916         if (lv)
1917             SvREFCNT_dec(LvTARG(lv));
1918         else {
1919             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1920             sv_upgrade(lv, SVt_PVLV);
1921             LvTYPE(lv) = 'y';
1922             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1923         }
1924         LvTARG(lv) = SvREFCNT_inc(av);
1925         LvTARGOFF(lv) = cx->blk_loop.iterix;
1926         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1927         sv = (SV*)lv;
1928     }
1929
1930     *itersvp = SvREFCNT_inc(sv);
1931     RETPUSHYES;
1932 }
1933
1934 PP(pp_subst)
1935 {
1936     dSP; dTARG;
1937     register PMOP *pm = cPMOP;
1938     PMOP *rpm = pm;
1939     register SV *dstr;
1940     register char *s;
1941     char *strend;
1942     register char *m;
1943     char *c;
1944     register char *d;
1945     STRLEN clen;
1946     I32 iters = 0;
1947     I32 maxiters;
1948     register I32 i;
1949     bool once;
1950     bool rxtainted;
1951     char *orig;
1952     I32 r_flags;
1953     register REGEXP *rx = PM_GETRE(pm);
1954     STRLEN len;
1955     int force_on_match = 0;
1956     I32 oldsave = PL_savestack_ix;
1957     STRLEN slen;
1958     bool doutf8 = FALSE;
1959 #ifdef PERL_COPY_ON_WRITE
1960     bool is_cow;
1961 #endif
1962     SV *nsv = Nullsv;
1963
1964     /* known replacement string? */
1965     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1966     if (PL_op->op_flags & OPf_STACKED)
1967         TARG = POPs;
1968     else {
1969         TARG = DEFSV;
1970         EXTEND(SP,1);
1971     }
1972
1973 #ifdef PERL_COPY_ON_WRITE
1974     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1975        because they make integers such as 256 "false".  */
1976     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1977 #else
1978     if (SvIsCOW(TARG))
1979         sv_force_normal_flags(TARG,0);
1980 #endif
1981     if (
1982 #ifdef PERL_COPY_ON_WRITE
1983         !is_cow &&
1984 #endif
1985         (SvREADONLY(TARG)
1986         || (SvTYPE(TARG) > SVt_PVLV
1987             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1988         DIE(aTHX_ PL_no_modify);
1989     PUTBACK;
1990
1991     s = SvPV(TARG, len);
1992     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1993         force_on_match = 1;
1994     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1995                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1996     if (PL_tainted)
1997         rxtainted |= 2;
1998     TAINT_NOT;
1999
2000     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2001
2002   force_it:
2003     if (!pm || !s)
2004         DIE(aTHX_ "panic: pp_subst");
2005
2006     strend = s + len;
2007     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2008     maxiters = 2 * slen + 10;   /* We can match twice at each
2009                                    position, once with zero-length,
2010                                    second time with non-zero. */
2011
2012     if (!rx->prelen && PL_curpm) {
2013         pm = PL_curpm;
2014         rx = PM_GETRE(pm);
2015     }
2016     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2017                ? REXEC_COPY_STR : 0;
2018     if (SvSCREAM(TARG))
2019         r_flags |= REXEC_SCREAM;
2020     if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
2021         SAVEINT(PL_multiline);
2022         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
2023     }
2024     orig = m = s;
2025     if (rx->reganch & RE_USE_INTUIT) {
2026         PL_bostr = orig;
2027         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2028
2029         if (!s)
2030             goto nope;
2031         /* How to do it in subst? */
2032 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2033              && !PL_sawampersand
2034              && ((rx->reganch & ROPT_NOSCAN)
2035                  || !((rx->reganch & RE_INTUIT_TAIL)
2036                       && (r_flags & REXEC_SCREAM))))
2037             goto yup;
2038 */
2039     }
2040
2041     /* only replace once? */
2042     once = !(rpm->op_pmflags & PMf_GLOBAL);
2043
2044     /* known replacement string? */
2045     if (dstr) {
2046         /* replacement needing upgrading? */
2047         if (DO_UTF8(TARG) && !doutf8) {
2048              nsv = sv_newmortal();
2049              SvSetSV(nsv, dstr);
2050              if (PL_encoding)
2051                   sv_recode_to_utf8(nsv, PL_encoding);
2052              else
2053                   sv_utf8_upgrade(nsv);
2054              c = SvPV(nsv, clen);
2055              doutf8 = TRUE;
2056         }
2057         else {
2058             c = SvPV(dstr, clen);
2059             doutf8 = DO_UTF8(dstr);
2060         }
2061     }
2062     else {
2063         c = Nullch;
2064         doutf8 = FALSE;
2065     }
2066     
2067     /* can do inplace substitution? */
2068     if (c
2069 #ifdef PERL_COPY_ON_WRITE
2070         && !is_cow
2071 #endif
2072         && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2073         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2074         && (!doutf8 || SvUTF8(TARG))) {
2075         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2076                          r_flags | REXEC_CHECKED))
2077         {
2078             SPAGAIN;
2079             PUSHs(&PL_sv_no);
2080             LEAVE_SCOPE(oldsave);
2081             RETURN;
2082         }
2083 #ifdef PERL_COPY_ON_WRITE
2084         if (SvIsCOW(TARG)) {
2085             assert (!force_on_match);
2086             goto have_a_cow;
2087         }
2088 #endif
2089         if (force_on_match) {
2090             force_on_match = 0;
2091             s = SvPV_force(TARG, len);
2092             goto force_it;
2093         }
2094         d = s;
2095         PL_curpm = pm;
2096         SvSCREAM_off(TARG);     /* disable possible screamer */
2097         if (once) {
2098             rxtainted |= RX_MATCH_TAINTED(rx);
2099             m = orig + rx->startp[0];
2100             d = orig + rx->endp[0];
2101             s = orig;
2102             if (m - s > strend - d) {  /* faster to shorten from end */
2103                 if (clen) {
2104                     Copy(c, m, clen, char);
2105                     m += clen;
2106                 }
2107                 i = strend - d;
2108                 if (i > 0) {
2109                     Move(d, m, i, char);
2110                     m += i;
2111                 }
2112                 *m = '\0';
2113                 SvCUR_set(TARG, m - s);
2114             }
2115             /*SUPPRESS 560*/
2116             else if ((i = m - s)) {     /* faster from front */
2117                 d -= clen;
2118                 m = d;
2119                 sv_chop(TARG, d-i);
2120                 s += i;
2121                 while (i--)
2122                     *--d = *--s;
2123                 if (clen)
2124                     Copy(c, m, clen, char);
2125             }
2126             else if (clen) {
2127                 d -= clen;
2128                 sv_chop(TARG, d);
2129                 Copy(c, d, clen, char);
2130             }
2131             else {
2132                 sv_chop(TARG, d);
2133             }
2134             TAINT_IF(rxtainted & 1);
2135             SPAGAIN;
2136             PUSHs(&PL_sv_yes);
2137         }
2138         else {
2139             do {
2140                 if (iters++ > maxiters)
2141                     DIE(aTHX_ "Substitution loop");
2142                 rxtainted |= RX_MATCH_TAINTED(rx);
2143                 m = rx->startp[0] + orig;
2144                 /*SUPPRESS 560*/
2145                 if ((i = m - s)) {
2146                     if (s != d)
2147                         Move(s, d, i, char);
2148                     d += i;
2149                 }
2150                 if (clen) {
2151                     Copy(c, d, clen, char);
2152                     d += clen;
2153                 }
2154                 s = rx->endp[0] + orig;
2155             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2156                                  TARG, NULL,
2157                                  /* don't match same null twice */
2158                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2159             if (s != d) {
2160                 i = strend - s;
2161                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2162                 Move(s, d, i+1, char);          /* include the NUL */
2163             }
2164             TAINT_IF(rxtainted & 1);
2165             SPAGAIN;
2166             PUSHs(sv_2mortal(newSViv((I32)iters)));
2167         }
2168         (void)SvPOK_only_UTF8(TARG);
2169         TAINT_IF(rxtainted);
2170         if (SvSMAGICAL(TARG)) {
2171             PUTBACK;
2172             mg_set(TARG);
2173             SPAGAIN;
2174         }
2175         SvTAINT(TARG);
2176         if (doutf8)
2177             SvUTF8_on(TARG);
2178         LEAVE_SCOPE(oldsave);
2179         RETURN;
2180     }
2181
2182     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2183                     r_flags | REXEC_CHECKED))
2184     {
2185         if (force_on_match) {
2186             force_on_match = 0;
2187             s = SvPV_force(TARG, len);
2188             goto force_it;
2189         }
2190 #ifdef PERL_COPY_ON_WRITE
2191       have_a_cow:
2192 #endif
2193         rxtainted |= RX_MATCH_TAINTED(rx);
2194         dstr = NEWSV(25, len);
2195         sv_setpvn(dstr, m, s-m);
2196         if (DO_UTF8(TARG))
2197             SvUTF8_on(dstr);
2198         PL_curpm = pm;
2199         if (!c) {
2200             register PERL_CONTEXT *cx;
2201             SPAGAIN;
2202             ReREFCNT_inc(rx);
2203             PUSHSUBST(cx);
2204             RETURNOP(cPMOP->op_pmreplroot);
2205         }
2206         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2207         do {
2208             if (iters++ > maxiters)
2209                 DIE(aTHX_ "Substitution loop");
2210             rxtainted |= RX_MATCH_TAINTED(rx);
2211             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2212                 m = s;
2213                 s = orig;
2214                 orig = rx->subbeg;
2215                 s = orig + (m - s);
2216                 strend = s + (strend - m);
2217             }
2218             m = rx->startp[0] + orig;
2219             if (doutf8 && !SvUTF8(dstr))
2220                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2221             else
2222                 sv_catpvn(dstr, s, m-s);
2223             s = rx->endp[0] + orig;
2224             if (clen)
2225                 sv_catpvn(dstr, c, clen);
2226             if (once)
2227                 break;
2228         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2229                              TARG, NULL, r_flags));
2230         if (doutf8 && !DO_UTF8(TARG))
2231             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2232         else
2233             sv_catpvn(dstr, s, strend - s);
2234
2235 #ifdef PERL_COPY_ON_WRITE
2236         /* The match may make the string COW. If so, brilliant, because that's
2237            just saved us one malloc, copy and free - the regexp has donated
2238            the old buffer, and we malloc an entirely new one, rather than the
2239            regexp malloc()ing a buffer and copying our original, only for
2240            us to throw it away here during the substitution.  */
2241         if (SvIsCOW(TARG)) {
2242             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2243         } else
2244 #endif
2245         {
2246             (void)SvOOK_off(TARG);
2247             if (SvLEN(TARG))
2248                 Safefree(SvPVX(TARG));
2249         }
2250         SvPVX(TARG) = SvPVX(dstr);
2251         SvCUR_set(TARG, SvCUR(dstr));
2252         SvLEN_set(TARG, SvLEN(dstr));
2253         doutf8 |= DO_UTF8(dstr);
2254         SvPVX(dstr) = 0;
2255         sv_free(dstr);
2256
2257         TAINT_IF(rxtainted & 1);
2258         SPAGAIN;
2259         PUSHs(sv_2mortal(newSViv((I32)iters)));
2260
2261         (void)SvPOK_only(TARG);
2262         if (doutf8)
2263             SvUTF8_on(TARG);
2264         TAINT_IF(rxtainted);
2265         SvSETMAGIC(TARG);
2266         SvTAINT(TARG);
2267         LEAVE_SCOPE(oldsave);
2268         RETURN;
2269     }
2270     goto ret_no;
2271
2272 nope:
2273 ret_no:
2274     SPAGAIN;
2275     PUSHs(&PL_sv_no);
2276     LEAVE_SCOPE(oldsave);
2277     RETURN;
2278 }
2279
2280 PP(pp_grepwhile)
2281 {
2282     dSP;
2283
2284     if (SvTRUEx(POPs))
2285         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2286     ++*PL_markstack_ptr;
2287     LEAVE;                                      /* exit inner scope */
2288
2289     /* All done yet? */
2290     if (PL_stack_base + *PL_markstack_ptr > SP) {
2291         I32 items;
2292         I32 gimme = GIMME_V;
2293
2294         LEAVE;                                  /* exit outer scope */
2295         (void)POPMARK;                          /* pop src */
2296         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2297         (void)POPMARK;                          /* pop dst */
2298         SP = PL_stack_base + POPMARK;           /* pop original mark */
2299         if (gimme == G_SCALAR) {
2300             dTARGET;
2301             XPUSHi(items);
2302         }
2303         else if (gimme == G_ARRAY)
2304             SP += items;
2305         RETURN;
2306     }
2307     else {
2308         SV *src;
2309
2310         ENTER;                                  /* enter inner scope */
2311         SAVEVPTR(PL_curpm);
2312
2313         src = PL_stack_base[*PL_markstack_ptr];
2314         SvTEMP_off(src);
2315         DEFSV = src;
2316
2317         RETURNOP(cLOGOP->op_other);
2318     }
2319 }
2320
2321 PP(pp_leavesub)
2322 {
2323     dSP;
2324     SV **mark;
2325     SV **newsp;
2326     PMOP *newpm;
2327     I32 gimme;
2328     register PERL_CONTEXT *cx;
2329     SV *sv;
2330
2331     POPBLOCK(cx,newpm);
2332     cxstack_ix++; /* temporarily protect top context */
2333
2334     TAINT_NOT;
2335     if (gimme == G_SCALAR) {
2336         MARK = newsp + 1;
2337         if (MARK <= SP) {
2338             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2339                 if (SvTEMP(TOPs)) {
2340                     *MARK = SvREFCNT_inc(TOPs);
2341                     FREETMPS;
2342                     sv_2mortal(*MARK);
2343                 }
2344                 else {
2345                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2346                     FREETMPS;
2347                     *MARK = sv_mortalcopy(sv);
2348                     SvREFCNT_dec(sv);
2349                 }
2350             }
2351             else
2352                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2353         }
2354         else {
2355             MEXTEND(MARK, 0);
2356             *MARK = &PL_sv_undef;
2357         }
2358         SP = MARK;
2359     }
2360     else if (gimme == G_ARRAY) {
2361         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2362             if (!SvTEMP(*MARK)) {
2363                 *MARK = sv_mortalcopy(*MARK);
2364                 TAINT_NOT;      /* Each item is independent */
2365             }
2366         }
2367     }
2368     PUTBACK;
2369
2370     LEAVE;
2371     cxstack_ix--;
2372     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2373     PL_curpm = newpm;   /* ... and pop $1 et al */
2374
2375     LEAVESUB(sv);
2376     return pop_return();
2377 }
2378
2379 /* This duplicates the above code because the above code must not
2380  * get any slower by more conditions */
2381 PP(pp_leavesublv)
2382 {
2383     dSP;
2384     SV **mark;
2385     SV **newsp;
2386     PMOP *newpm;
2387     I32 gimme;
2388     register PERL_CONTEXT *cx;
2389     SV *sv;
2390
2391     POPBLOCK(cx,newpm);
2392     cxstack_ix++; /* temporarily protect top context */
2393
2394     TAINT_NOT;
2395
2396     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2397         /* We are an argument to a function or grep().
2398          * This kind of lvalueness was legal before lvalue
2399          * subroutines too, so be backward compatible:
2400          * cannot report errors.  */
2401
2402         /* Scalar context *is* possible, on the LHS of -> only,
2403          * as in f()->meth().  But this is not an lvalue. */
2404         if (gimme == G_SCALAR)
2405             goto temporise;
2406         if (gimme == G_ARRAY) {
2407             if (!CvLVALUE(cx->blk_sub.cv))
2408                 goto temporise_array;
2409             EXTEND_MORTAL(SP - newsp);
2410             for (mark = newsp + 1; mark <= SP; mark++) {
2411                 if (SvTEMP(*mark))
2412                     /* empty */ ;
2413                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2414                     *mark = sv_mortalcopy(*mark);
2415                 else {
2416                     /* Can be a localized value subject to deletion. */
2417                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2418                     (void)SvREFCNT_inc(*mark);
2419                 }
2420             }
2421         }
2422     }
2423     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2424         /* Here we go for robustness, not for speed, so we change all
2425          * the refcounts so the caller gets a live guy. Cannot set
2426          * TEMP, so sv_2mortal is out of question. */
2427         if (!CvLVALUE(cx->blk_sub.cv)) {
2428             LEAVE;
2429             cxstack_ix--;
2430             POPSUB(cx,sv);
2431             PL_curpm = newpm;
2432             LEAVESUB(sv);
2433             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2434         }
2435         if (gimme == G_SCALAR) {
2436             MARK = newsp + 1;
2437             EXTEND_MORTAL(1);
2438             if (MARK == SP) {
2439                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2440                     LEAVE;
2441                     cxstack_ix--;
2442                     POPSUB(cx,sv);
2443                     PL_curpm = newpm;
2444                     LEAVESUB(sv);
2445                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2446                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2447                         : "a readonly value" : "a temporary");
2448                 }
2449                 else {                  /* Can be a localized value
2450                                          * subject to deletion. */
2451                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2452                     (void)SvREFCNT_inc(*mark);
2453                 }
2454             }
2455             else {                      /* Should not happen? */
2456                 LEAVE;
2457                 cxstack_ix--;
2458                 POPSUB(cx,sv);
2459                 PL_curpm = newpm;
2460                 LEAVESUB(sv);
2461                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2462                     (MARK > SP ? "Empty array" : "Array"));
2463             }
2464             SP = MARK;
2465         }
2466         else if (gimme == G_ARRAY) {
2467             EXTEND_MORTAL(SP - newsp);
2468             for (mark = newsp + 1; mark <= SP; mark++) {
2469                 if (*mark != &PL_sv_undef
2470                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2471                     /* Might be flattened array after $#array =  */
2472                     PUTBACK;
2473                     LEAVE;
2474                     cxstack_ix--;
2475                     POPSUB(cx,sv);
2476                     PL_curpm = newpm;
2477                     LEAVESUB(sv);
2478                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2479                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2480                 }
2481                 else {
2482                     /* Can be a localized value subject to deletion. */
2483                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2484                     (void)SvREFCNT_inc(*mark);
2485                 }
2486             }
2487         }
2488     }
2489     else {
2490         if (gimme == G_SCALAR) {
2491           temporise:
2492             MARK = newsp + 1;
2493             if (MARK <= SP) {
2494                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2495                     if (SvTEMP(TOPs)) {
2496                         *MARK = SvREFCNT_inc(TOPs);
2497                         FREETMPS;
2498                         sv_2mortal(*MARK);
2499                     }
2500                     else {
2501                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2502                         FREETMPS;
2503                         *MARK = sv_mortalcopy(sv);
2504                         SvREFCNT_dec(sv);
2505                     }
2506                 }
2507                 else
2508                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2509             }
2510             else {
2511                 MEXTEND(MARK, 0);
2512                 *MARK = &PL_sv_undef;
2513             }
2514             SP = MARK;
2515         }
2516         else if (gimme == G_ARRAY) {
2517           temporise_array:
2518             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2519                 if (!SvTEMP(*MARK)) {
2520                     *MARK = sv_mortalcopy(*MARK);
2521                     TAINT_NOT;  /* Each item is independent */
2522                 }
2523             }
2524         }
2525     }
2526     PUTBACK;
2527
2528     LEAVE;
2529     cxstack_ix--;
2530     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2531     PL_curpm = newpm;   /* ... and pop $1 et al */
2532
2533     LEAVESUB(sv);
2534     return pop_return();
2535 }
2536
2537
2538 STATIC CV *
2539 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2540 {
2541     SV *dbsv = GvSV(PL_DBsub);
2542
2543     if (!PERLDB_SUB_NN) {
2544         GV *gv = CvGV(cv);
2545
2546         save_item(dbsv);
2547         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2548              || strEQ(GvNAME(gv), "END")
2549              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2550                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2551                     && (gv = (GV*)*svp) ))) {
2552             /* Use GV from the stack as a fallback. */
2553             /* GV is potentially non-unique, or contain different CV. */
2554             SV *tmp = newRV((SV*)cv);
2555             sv_setsv(dbsv, tmp);
2556             SvREFCNT_dec(tmp);
2557         }
2558         else {
2559             gv_efullname3(dbsv, gv, Nullch);
2560         }
2561     }
2562     else {
2563         (void)SvUPGRADE(dbsv, SVt_PVIV);
2564         (void)SvIOK_on(dbsv);
2565         SAVEIV(SvIVX(dbsv));
2566         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2567     }
2568
2569     if (CvXSUB(cv))
2570         PL_curcopdb = PL_curcop;
2571     cv = GvCV(PL_DBsub);
2572     return cv;
2573 }
2574
2575 PP(pp_entersub)
2576 {
2577     dSP; dPOPss;
2578     GV *gv;
2579     HV *stash;
2580     register CV *cv;
2581     register PERL_CONTEXT *cx;
2582     I32 gimme;
2583     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2584
2585     if (!sv)
2586         DIE(aTHX_ "Not a CODE reference");
2587     switch (SvTYPE(sv)) {
2588         /* This is overwhelming the most common case:  */
2589     case SVt_PVGV:
2590         if (!(cv = GvCVu((GV*)sv)))
2591             cv = sv_2cv(sv, &stash, &gv, FALSE);
2592         if (!cv) {
2593             ENTER;
2594             SAVETMPS;
2595             goto try_autoload;
2596         }
2597         break;
2598     default:
2599         if (!SvROK(sv)) {
2600             char *sym;
2601             STRLEN n_a;
2602
2603             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2604                 if (hasargs)
2605                     SP = PL_stack_base + POPMARK;
2606                 RETURN;
2607             }
2608             if (SvGMAGICAL(sv)) {
2609                 mg_get(sv);
2610                 if (SvROK(sv))
2611                     goto got_rv;
2612                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2613             }
2614             else
2615                 sym = SvPV(sv, n_a);
2616             if (!sym)
2617                 DIE(aTHX_ PL_no_usym, "a subroutine");
2618             if (PL_op->op_private & HINT_STRICT_REFS)
2619                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2620             cv = get_cv(sym, TRUE);
2621             break;
2622         }
2623   got_rv:
2624         {
2625             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2626             tryAMAGICunDEREF(to_cv);
2627         }       
2628         cv = (CV*)SvRV(sv);
2629         if (SvTYPE(cv) == SVt_PVCV)
2630             break;
2631         /* FALL THROUGH */
2632     case SVt_PVHV:
2633     case SVt_PVAV:
2634         DIE(aTHX_ "Not a CODE reference");
2635         /* This is the second most common case:  */
2636     case SVt_PVCV:
2637         cv = (CV*)sv;
2638         break;
2639     }
2640
2641     ENTER;
2642     SAVETMPS;
2643
2644   retry:
2645     if (!CvROOT(cv) && !CvXSUB(cv)) {
2646         goto fooey;
2647     }
2648
2649     gimme = GIMME_V;
2650     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2651         if (CvASSERTION(cv) && PL_DBassertion)
2652             sv_setiv(PL_DBassertion, 1);
2653         
2654         cv = get_db_sub(&sv, cv);
2655         if (!cv)
2656             DIE(aTHX_ "No DBsub routine");
2657     }
2658
2659     if (!(CvXSUB(cv))) {
2660         /* This path taken at least 75% of the time   */
2661         dMARK;
2662         register I32 items = SP - MARK;
2663         AV* padlist = CvPADLIST(cv);
2664         push_return(PL_op->op_next);
2665         PUSHBLOCK(cx, CXt_SUB, MARK);
2666         PUSHSUB(cx);
2667         CvDEPTH(cv)++;
2668         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2669          * that eval'' ops within this sub know the correct lexical space.
2670          * Owing the speed considerations, we choose instead to search for
2671          * the cv using find_runcv() when calling doeval().
2672          */
2673         if (CvDEPTH(cv) < 2)
2674             (void)SvREFCNT_inc(cv);
2675         else {
2676             PERL_STACK_OVERFLOW_CHECK();
2677             pad_push(padlist, CvDEPTH(cv), 1);
2678         }
2679         PAD_SET_CUR(padlist, CvDEPTH(cv));
2680         if (hasargs)
2681         {
2682             AV* av;
2683             SV** ary;
2684
2685 #if 0
2686             DEBUG_S(PerlIO_printf(Perl_debug_log,
2687                                   "%p entersub preparing @_\n", thr));
2688 #endif
2689             av = (AV*)PAD_SVl(0);
2690             if (AvREAL(av)) {
2691                 /* @_ is normally not REAL--this should only ever
2692                  * happen when DB::sub() calls things that modify @_ */
2693                 av_clear(av);
2694                 AvREAL_off(av);
2695                 AvREIFY_on(av);
2696             }
2697             cx->blk_sub.savearray = GvAV(PL_defgv);
2698             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2699             CX_CURPAD_SAVE(cx->blk_sub);
2700             cx->blk_sub.argarray = av;
2701             ++MARK;
2702
2703             if (items > AvMAX(av) + 1) {
2704                 ary = AvALLOC(av);
2705                 if (AvARRAY(av) != ary) {
2706                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2707                     SvPVX(av) = (char*)ary;
2708                 }
2709                 if (items > AvMAX(av) + 1) {
2710                     AvMAX(av) = items - 1;
2711                     Renew(ary,items,SV*);
2712                     AvALLOC(av) = ary;
2713                     SvPVX(av) = (char*)ary;
2714                 }
2715             }
2716             Copy(MARK,AvARRAY(av),items,SV*);
2717             AvFILLp(av) = items - 1;
2718         
2719             while (items--) {
2720                 if (*MARK)
2721                     SvTEMP_off(*MARK);
2722                 MARK++;
2723             }
2724         }
2725         /* warning must come *after* we fully set up the context
2726          * stuff so that __WARN__ handlers can safely dounwind()
2727          * if they want to
2728          */
2729         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2730             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2731             sub_crush_depth(cv);
2732 #if 0
2733         DEBUG_S(PerlIO_printf(Perl_debug_log,
2734                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2735 #endif
2736         RETURNOP(CvSTART(cv));
2737     }
2738     else {
2739 #ifdef PERL_XSUB_OLDSTYLE
2740         if (CvOLDSTYLE(cv)) {
2741             I32 (*fp3)(int,int,int);
2742             dMARK;
2743             register I32 items = SP - MARK;
2744                                         /* We dont worry to copy from @_. */
2745             while (SP > mark) {
2746                 SP[1] = SP[0];
2747                 SP--;
2748             }
2749             PL_stack_sp = mark + 1;
2750             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2751             items = (*fp3)(CvXSUBANY(cv).any_i32,
2752                            MARK - PL_stack_base + 1,
2753                            items);
2754             PL_stack_sp = PL_stack_base + items;
2755         }
2756         else
2757 #endif /* PERL_XSUB_OLDSTYLE */
2758         {
2759             I32 markix = TOPMARK;
2760
2761             PUTBACK;
2762
2763             if (!hasargs) {
2764                 /* Need to copy @_ to stack. Alternative may be to
2765                  * switch stack to @_, and copy return values
2766                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2767                 AV* av;
2768                 I32 items;
2769                 av = GvAV(PL_defgv);
2770                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2771
2772                 if (items) {
2773                     /* Mark is at the end of the stack. */
2774                     EXTEND(SP, items);
2775                     Copy(AvARRAY(av), SP + 1, items, SV*);
2776                     SP += items;
2777                     PUTBACK ;           
2778                 }
2779             }
2780             /* We assume first XSUB in &DB::sub is the called one. */
2781             if (PL_curcopdb) {
2782                 SAVEVPTR(PL_curcop);
2783                 PL_curcop = PL_curcopdb;
2784                 PL_curcopdb = NULL;
2785             }
2786             /* Do we need to open block here? XXXX */
2787             (void)(*CvXSUB(cv))(aTHX_ cv);
2788
2789             /* Enforce some sanity in scalar context. */
2790             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2791                 if (markix > PL_stack_sp - PL_stack_base)
2792                     *(PL_stack_base + markix) = &PL_sv_undef;
2793                 else
2794                     *(PL_stack_base + markix) = *PL_stack_sp;
2795                 PL_stack_sp = PL_stack_base + markix;
2796             }
2797         }
2798         LEAVE;
2799         return NORMAL;
2800     }
2801
2802     assert (0); /* Cannot get here.  */
2803     /* This is deliberately moved here as spaghetti code to keep it out of the
2804        hot path.  */
2805     {
2806         GV* autogv;
2807         SV* sub_name;
2808
2809       fooey:
2810         /* anonymous or undef'd function leaves us no recourse */
2811         if (CvANON(cv) || !(gv = CvGV(cv)))
2812             DIE(aTHX_ "Undefined subroutine called");
2813
2814         /* autoloaded stub? */
2815         if (cv != GvCV(gv)) {
2816             cv = GvCV(gv);
2817         }
2818         /* should call AUTOLOAD now? */
2819         else {
2820 try_autoload:
2821             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2822                                    FALSE)))
2823             {
2824                 cv = GvCV(autogv);
2825             }
2826             /* sorry */
2827             else {
2828                 sub_name = sv_newmortal();
2829                 gv_efullname3(sub_name, gv, Nullch);
2830                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2831             }
2832         }
2833         if (!cv)
2834             DIE(aTHX_ "Not a CODE reference");
2835         goto retry;
2836     }
2837 }
2838
2839 void
2840 Perl_sub_crush_depth(pTHX_ CV *cv)
2841 {
2842     if (CvANON(cv))
2843         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2844     else {
2845         SV* tmpstr = sv_newmortal();
2846         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2847         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2848                 tmpstr);
2849     }
2850 }
2851
2852 PP(pp_aelem)
2853 {
2854     dSP;
2855     SV** svp;
2856     SV* elemsv = POPs;
2857     IV elem = SvIV(elemsv);
2858     AV* av = (AV*)POPs;
2859     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2860     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2861     SV *sv;
2862
2863     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2864         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2865     if (elem > 0)
2866         elem -= PL_curcop->cop_arybase;
2867     if (SvTYPE(av) != SVt_PVAV)
2868         RETPUSHUNDEF;
2869     svp = av_fetch(av, elem, lval && !defer);
2870     if (lval) {
2871         if (!svp || *svp == &PL_sv_undef) {
2872             SV* lv;
2873             if (!defer)
2874                 DIE(aTHX_ PL_no_aelem, elem);
2875             lv = sv_newmortal();
2876             sv_upgrade(lv, SVt_PVLV);
2877             LvTYPE(lv) = 'y';
2878             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2879             LvTARG(lv) = SvREFCNT_inc(av);
2880             LvTARGOFF(lv) = elem;
2881             LvTARGLEN(lv) = 1;
2882             PUSHs(lv);
2883             RETURN;
2884         }
2885         if (PL_op->op_private & OPpLVAL_INTRO)
2886             save_aelem(av, elem, svp);
2887         else if (PL_op->op_private & OPpDEREF)
2888             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2889     }
2890     sv = (svp ? *svp : &PL_sv_undef);
2891     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2892         sv = sv_mortalcopy(sv);
2893     PUSHs(sv);
2894     RETURN;
2895 }
2896
2897 void
2898 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2899 {
2900     if (SvGMAGICAL(sv))
2901         mg_get(sv);
2902     if (!SvOK(sv)) {
2903         if (SvREADONLY(sv))
2904             Perl_croak(aTHX_ PL_no_modify);
2905         if (SvTYPE(sv) < SVt_RV)
2906             sv_upgrade(sv, SVt_RV);
2907         else if (SvTYPE(sv) >= SVt_PV) {
2908             (void)SvOOK_off(sv);
2909             Safefree(SvPVX(sv));
2910             SvLEN(sv) = SvCUR(sv) = 0;
2911         }
2912         switch (to_what) {
2913         case OPpDEREF_SV:
2914             SvRV(sv) = NEWSV(355,0);
2915             break;
2916         case OPpDEREF_AV:
2917             SvRV(sv) = (SV*)newAV();
2918             break;
2919         case OPpDEREF_HV:
2920             SvRV(sv) = (SV*)newHV();
2921             break;
2922         }
2923         SvROK_on(sv);
2924         SvSETMAGIC(sv);
2925     }
2926 }
2927
2928 PP(pp_method)
2929 {
2930     dSP;
2931     SV* sv = TOPs;
2932
2933     if (SvROK(sv)) {
2934         SV* rsv = SvRV(sv);
2935         if (SvTYPE(rsv) == SVt_PVCV) {
2936             SETs(rsv);
2937             RETURN;
2938         }
2939     }
2940
2941     SETs(method_common(sv, Null(U32*)));
2942     RETURN;
2943 }
2944
2945 PP(pp_method_named)
2946 {
2947     dSP;
2948     SV* sv = cSVOP_sv;
2949     U32 hash = SvUVX(sv);
2950
2951     XPUSHs(method_common(sv, &hash));
2952     RETURN;
2953 }
2954
2955 STATIC SV *
2956 S_method_common(pTHX_ SV* meth, U32* hashp)
2957 {
2958     SV* sv;
2959     SV* ob;
2960     GV* gv;
2961     HV* stash;
2962     char* name;
2963     STRLEN namelen;
2964     char* packname = 0;
2965     SV *packsv = Nullsv;
2966     STRLEN packlen;
2967
2968     name = SvPV(meth, namelen);
2969     sv = *(PL_stack_base + TOPMARK + 1);
2970
2971     if (!sv)
2972         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2973
2974     if (SvGMAGICAL(sv))
2975         mg_get(sv);
2976     if (SvROK(sv))
2977         ob = (SV*)SvRV(sv);
2978     else {
2979         GV* iogv;
2980
2981         /* this isn't a reference */
2982         packname = Nullch;
2983
2984         if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2985           HE* he;
2986           he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2987           if (he) { 
2988             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2989             goto fetch;
2990           }
2991         }
2992
2993         if (!SvOK(sv) ||
2994             !(packname) ||
2995             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2996             !(ob=(SV*)GvIO(iogv)))
2997         {
2998             /* this isn't the name of a filehandle either */
2999             if (!packname ||
3000                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3001                     ? !isIDFIRST_utf8((U8*)packname)
3002                     : !isIDFIRST(*packname)
3003                 ))
3004             {
3005                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3006                            SvOK(sv) ? "without a package or object reference"
3007                                     : "on an undefined value");
3008             }
3009             /* assume it's a package name */
3010             stash = gv_stashpvn(packname, packlen, FALSE);
3011             if (!stash)
3012                 packsv = sv;
3013             else {
3014                 SV* ref = newSViv(PTR2IV(stash));
3015                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3016             }
3017             goto fetch;
3018         }
3019         /* it _is_ a filehandle name -- replace with a reference */
3020         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3021     }
3022
3023     /* if we got here, ob should be a reference or a glob */
3024     if (!ob || !(SvOBJECT(ob)
3025                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3026                      && SvOBJECT(ob))))
3027     {
3028         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3029                    name);
3030     }
3031
3032     stash = SvSTASH(ob);
3033
3034   fetch:
3035     /* NOTE: stash may be null, hope hv_fetch_ent and
3036        gv_fetchmethod can cope (it seems they can) */
3037
3038     /* shortcut for simple names */
3039     if (hashp) {
3040         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3041         if (he) {
3042             gv = (GV*)HeVAL(he);
3043             if (isGV(gv) && GvCV(gv) &&
3044                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3045                 return (SV*)GvCV(gv);
3046         }
3047     }
3048
3049     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3050
3051     if (!gv) {
3052         /* This code tries to figure out just what went wrong with
3053            gv_fetchmethod.  It therefore needs to duplicate a lot of
3054            the internals of that function.  We can't move it inside
3055            Perl_gv_fetchmethod_autoload(), however, since that would
3056            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3057            don't want that.
3058         */
3059         char* leaf = name;
3060         char* sep = Nullch;
3061         char* p;
3062
3063         for (p = name; *p; p++) {
3064             if (*p == '\'')
3065                 sep = p, leaf = p + 1;
3066             else if (*p == ':' && *(p + 1) == ':')
3067                 sep = p, leaf = p + 2;
3068         }
3069         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3070             /* the method name is unqualified or starts with SUPER:: */ 
3071             packname = sep ? CopSTASHPV(PL_curcop) :
3072                 stash ? HvNAME(stash) : packname;
3073             if (!packname)
3074                 Perl_croak(aTHX_
3075                            "Can't use anonymous symbol table for method lookup");
3076             else
3077                 packlen = strlen(packname);
3078         }
3079         else {
3080             /* the method name is qualified */
3081             packname = name;
3082             packlen = sep - name;
3083         }
3084         
3085         /* we're relying on gv_fetchmethod not autovivifying the stash */
3086         if (gv_stashpvn(packname, packlen, FALSE)) {
3087             Perl_croak(aTHX_
3088                        "Can't locate object method \"%s\" via package \"%.*s\"",
3089                        leaf, (int)packlen, packname);
3090         }
3091         else {
3092             Perl_croak(aTHX_
3093                        "Can't locate object method \"%s\" via package \"%.*s\""
3094                        " (perhaps you forgot to load \"%.*s\"?)",
3095                        leaf, (int)packlen, packname, (int)packlen, packname);
3096         }
3097     }
3098     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3099 }