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