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