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