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