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