Context Navigation

pp_hot.c @ 20075

Visit:

Revision 20075, 76.1 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/third/perl/pp_hot.c @ 20075

Download in other formats: