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