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