Context Navigation

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

Visit:

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

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

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

Download in other formats: