Context Navigation

source: trunk/third/perl/op.c @ 14545

Visit:

Revision 14545, 158.9 KB checked in by ghudson, 25 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, which included commits to RCS files with non-trunk default branches.

Line
1	/* op.c
2	*
3	* Copyright (c) 1991-2000, 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	* "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
12	* our Mr. Bilbo's first cousin on the mother's side (her mother being the
13	* youngest of the Old Took's daughters); and Mr. Drogo was his second
14	* cousin. So Mr. Frodo is his first and second cousin, once removed
15	* either way, as the saying is, if you follow me." --the Gaffer
16	*/
17
18	#include "EXTERN.h"
19	#define PERL_IN_OP_C
20	#include "perl.h"
21	#include "keywords.h"
22
23	/* #define PL_OP_SLAB_ALLOC */
24
25	#ifdef PL_OP_SLAB_ALLOC
26	#define SLAB_SIZE 8192
27	static char *PL_OpPtr = NULL;
28	static int PL_OpSpace = 0;
29	#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
30	var = (type )(PL_OpPtr -= csizeof(type)); \
31	else \
32	var = (type ) Slab_Alloc(m,csizeof(type)); \
33	} while (0)
34
35	STATIC void *
36	S_Slab_Alloc(pTHX_ int m, size_t sz)
37	{
38	Newz(m,PL_OpPtr,SLAB_SIZE,char);
39	PL_OpSpace = SLAB_SIZE - sz;
40	return PL_OpPtr += PL_OpSpace;
41	}
42
43	#else
44	#define NewOp(m, var, c, type) Newz(m, var, c, type)
45	#endif
46	/*
47	* In the following definition, the ", Nullop" is just to make the compiler
48	* think the expression is of the right type: croak actually does a Siglongjmp.
49	*/
50	#define CHECKOP(type,o) \
51	((PL_op_mask && PL_op_mask[type]) \
52	? ( op_free((OP*)o), \
53	Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \
54	Nullop ) \
55	: CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
56
57	#define PAD_MAX 999999999
58
59	STATIC char*
60	S_gv_ename(pTHX_ GV *gv)
61	{
62	STRLEN n_a;
63	SV* tmpsv = sv_newmortal();
64	gv_efullname3(tmpsv, gv, Nullch);
65	return SvPV(tmpsv,n_a);
66	}
67
68	STATIC OP *
69	S_no_fh_allowed(pTHX_ OP *o)
70	{
71	yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
72	PL_op_desc[o->op_type]));
73	return o;
74	}
75
76	STATIC OP *
77	S_too_few_arguments(pTHX_ OP o, char name)
78	{
79	yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
80	return o;
81	}
82
83	STATIC OP *
84	S_too_many_arguments(pTHX_ OP o, char name)
85	{
86	yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
87	return o;
88	}
89
90	STATIC void
91	S_bad_type(pTHX_ I32 n, char t, char name, OP *kid)
92	{
93	yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
94	(int)n, name, t, PL_op_desc[kid->op_type]));
95	}
96
97	STATIC void
98	S_no_bareword_allowed(pTHX_ OP *o)
99	{
100	qerror(Perl_mess(aTHX_
101	"Bareword \"%s\" not allowed while \"strict subs\" in use",
102	SvPV_nolen(cSVOPo_sv)));
103	}
104
105	/* "register" allocation */
106
107	PADOFFSET
108	Perl_pad_allocmy(pTHX_ char *name)
109	{
110	dTHR;
111	PADOFFSET off;
112	SV *sv;
113
114	if (!(PL_in_my == KEY_our \|\|
115	isALPHA(name[1]) \|\|
116	(PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) \|\|
117	(name[1] == '_' && (int)strlen(name) > 2)))
118	{
119	if (!isPRINT(name[1]) \|\| strchr("\t\n\r\f", name[1])) {
120	/* 1999-02-27 mjd@plover.com */
121	char *p;
122	p = strchr(name, '\0');
123	/* The next block assumes the buffer is at least 205 chars
124	long. At present, it's always at least 256 chars. */
125	if (p-name > 200) {
126	strcpy(name+200, "...");
127	p = name+199;
128	}
129	else {
130	p[1] = '\0';
131	}
132	/* Move everything else down one character */
133	for (; p-name > 2; p--)
134	p = (p-1);
135	name[2] = toCTRL(name[1]);
136	name[1] = '^';
137	}
138	yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
139	}
140	if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
141	SV **svp = AvARRAY(PL_comppad_name);
142	HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
143	PADOFFSET top = AvFILLp(PL_comppad_name);
144	for (off = top; off > PL_comppad_name_floor; off--) {
145	if ((sv = svp[off])
146	&& sv != &PL_sv_undef
147	&& (SvIVX(sv) == PAD_MAX \|\| SvIVX(sv) == 0)
148	&& (PL_in_my != KEY_our
149	\|\| ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
150	&& strEQ(name, SvPVX(sv)))
151	{
152	Perl_warner(aTHX_ WARN_MISC,
153	"\"%s\" variable %s masks earlier declaration in same %s",
154	(PL_in_my == KEY_our ? "our" : "my"),
155	name,
156	(SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
157	--off;
158	break;
159	}
160	}
161	if (PL_in_my == KEY_our) {
162	do {
163	if ((sv = svp[off])
164	&& sv != &PL_sv_undef
165	&& ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
166	&& strEQ(name, SvPVX(sv)))
167	{
168	Perl_warner(aTHX_ WARN_MISC,
169	"\"our\" variable %s redeclared", name);
170	Perl_warner(aTHX_ WARN_MISC,
171	"\t(Did you mean \"local\" instead of \"our\"?)\n");
172	break;
173	}
174	} while ( off-- > 0 );
175	}
176	}
177	off = pad_alloc(OP_PADSV, SVs_PADMY);
178	sv = NEWSV(1102,0);
179	sv_upgrade(sv, SVt_PVNV);
180	sv_setpv(sv, name);
181	if (PL_in_my_stash) {
182	if (*name != '$')
183	yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
184	name, PL_in_my == KEY_our ? "our" : "my"));
185	SvOBJECT_on(sv);
186	(void)SvUPGRADE(sv, SVt_PVMG);
187	SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
188	PL_sv_objcount++;
189	}
190	if (PL_in_my == KEY_our) {
191	(void)SvUPGRADE(sv, SVt_PVGV);
192	GvSTASH(sv) = (HV)SvREFCNT_inc(PL_curstash ? (SV)PL_curstash : (SV*)PL_defstash);
193	SvFLAGS(sv) \|= SVpad_OUR;
194	}
195	av_store(PL_comppad_name, off, sv);
196	SvNVX(sv) = (NV)PAD_MAX;
197	SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
198	if (!PL_min_intro_pending)
199	PL_min_intro_pending = off;
200	PL_max_intro_pending = off;
201	if (*name == '@')
202	av_store(PL_comppad, off, (SV*)newAV());
203	else if (*name == '%')
204	av_store(PL_comppad, off, (SV*)newHV());
205	SvPADMY_on(PL_curpad[off]);
206	return off;
207	}
208
209	STATIC PADOFFSET
210	S_pad_addlex(pTHX_ SV *proto_namesv)
211	{
212	SV *namesv = NEWSV(1103,0);
213	PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
214	sv_upgrade(namesv, SVt_PVNV);
215	sv_setpv(namesv, SvPVX(proto_namesv));
216	av_store(PL_comppad_name, newoff, namesv);
217	SvNVX(namesv) = (NV)PL_curcop->cop_seq;
218	SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
219	SvFAKE_on(namesv); /* A ref, not a real var */
220	if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */
221	SvFLAGS(namesv) \|= SVpad_OUR;
222	(void)SvUPGRADE(namesv, SVt_PVGV);
223	GvSTASH(namesv) = (HV)SvREFCNT_inc((SV)GvSTASH(proto_namesv));
224	}
225	if (SvOBJECT(proto_namesv)) { /* A typed var */
226	SvOBJECT_on(namesv);
227	(void)SvUPGRADE(namesv, SVt_PVMG);
228	SvSTASH(namesv) = (HV)SvREFCNT_inc((SV)SvSTASH(proto_namesv));
229	PL_sv_objcount++;
230	}
231	return newoff;
232	}
233
234	#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */
235
236	STATIC PADOFFSET
237	S_pad_findlex(pTHX_ char name, PADOFFSET newoff, U32 seq, CV startcv,
238	I32 cx_ix, I32 saweval, U32 flags)
239	{
240	dTHR;
241	CV *cv;
242	I32 off;
243	SV *sv;
244	register I32 i;
245	register PERL_CONTEXT *cx;
246
247	for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
248	AV *curlist = CvPADLIST(cv);
249	SV **svp = av_fetch(curlist, 0, FALSE);
250	AV *curname;
251
252	if (!svp \|\| *svp == &PL_sv_undef)
253	continue;
254	curname = (AV)svp;
255	svp = AvARRAY(curname);
256	for (off = AvFILLp(curname); off > 0; off--) {
257	if ((sv = svp[off]) &&
258	sv != &PL_sv_undef &&
259	seq <= SvIVX(sv) &&
260	seq > I_32(SvNVX(sv)) &&
261	strEQ(SvPVX(sv), name))
262	{
263	I32 depth;
264	AV *oldpad;
265	SV *oldsv;
266
267	depth = CvDEPTH(cv);
268	if (!depth) {
269	if (newoff) {
270	if (SvFAKE(sv))
271	continue;
272	return 0; /* don't clone from inactive stack frame */
273	}
274	depth = 1;
275	}
276	oldpad = (AV*)AvARRAY(curlist)[depth];
277	oldsv = *av_fetch(oldpad, off, TRUE);
278	if (!newoff) { /* Not a mere clone operation. */
279	newoff = pad_addlex(sv);
280	if (CvANON(PL_compcv) \|\| SvTYPE(PL_compcv) == SVt_PVFM) {
281	/* "It's closures all the way down." */
282	CvCLONE_on(PL_compcv);
283	if (cv == startcv) {
284	if (CvANON(PL_compcv))
285	oldsv = Nullsv; /* no need to keep ref */
286	}
287	else {
288	CV *bcv;
289	for (bcv = startcv;
290	bcv && bcv != cv && !CvCLONE(bcv);
291	bcv = CvOUTSIDE(bcv))
292	{
293	if (CvANON(bcv)) {
294	/* install the missing pad entry in intervening
295	* nested subs and mark them cloneable.
296	* XXX fix pad_foo() to not use globals */
297	AV *ocomppad_name = PL_comppad_name;
298	AV *ocomppad = PL_comppad;
299	SV **ocurpad = PL_curpad;
300	AV *padlist = CvPADLIST(bcv);
301	PL_comppad_name = (AV*)AvARRAY(padlist)[0];
302	PL_comppad = (AV*)AvARRAY(padlist)[1];
303	PL_curpad = AvARRAY(PL_comppad);
304	pad_addlex(sv);
305	PL_comppad_name = ocomppad_name;
306	PL_comppad = ocomppad;
307	PL_curpad = ocurpad;
308	CvCLONE_on(bcv);
309	}
310	else {
311	if (ckWARN(WARN_CLOSURE)
312	&& !CvUNIQUE(bcv) && !CvUNIQUE(cv))
313	{
314	Perl_warner(aTHX_ WARN_CLOSURE,
315	"Variable \"%s\" may be unavailable",
316	name);
317	}
318	break;
319	}
320	}
321	}
322	}
323	else if (!CvUNIQUE(PL_compcv)) {
324	if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv))
325	Perl_warner(aTHX_ WARN_CLOSURE,
326	"Variable \"%s\" will not stay shared", name);
327	}
328	}
329	av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
330	return newoff;
331	}
332	}
333	}
334
335	if (flags & FINDLEX_NOSEARCH)
336	return 0;
337
338	/* Nothing in current lexical context--try eval's context, if any.
339	* This is necessary to let the perldb get at lexically scoped variables.
340	* XXX This will also probably interact badly with eval tree caching.
341	*/
342
343	for (i = cx_ix; i >= 0; i--) {
344	cx = &cxstack[i];
345	switch (CxTYPE(cx)) {
346	default:
347	if (i == 0 && saweval) {
348	seq = cxstack[saweval].blk_oldcop->cop_seq;
349	return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
350	}
351	break;
352	case CXt_EVAL:
353	switch (cx->blk_eval.old_op_type) {
354	case OP_ENTEREVAL:
355	if (CxREALEVAL(cx))
356	saweval = i;
357	break;
358	case OP_DOFILE:
359	case OP_REQUIRE:
360	/* require/do must have their own scope */
361	return 0;
362	}
363	break;
364	case CXt_FORMAT:
365	case CXt_SUB:
366	if (!saweval)
367	return 0;
368	cv = cx->blk_sub.cv;
369	if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
370	saweval = i; /* so we know where we were called from */
371	continue;
372	}
373	seq = cxstack[saweval].blk_oldcop->cop_seq;
374	return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
375	}
376	}
377
378	return 0;
379	}
380
381	PADOFFSET
382	Perl_pad_findmy(pTHX_ char *name)
383	{
384	dTHR;
385	I32 off;
386	I32 pendoff = 0;
387	SV *sv;
388	SV **svp = AvARRAY(PL_comppad_name);
389	U32 seq = PL_cop_seqmax;
390	PERL_CONTEXT *cx;
391	CV *outside;
392
393	#ifdef USE_THREADS
394	/*
395	* Special case to get lexical (and hence per-thread) @_.
396	* XXX I need to find out how to tell at parse-time whether use
397	* of @_ should refer to a lexical (from a sub) or defgv (global
398	* scope and maybe weird sub-ish things like formats). See
399	* startsub in perly.y. It's possible that @_ could be lexical
400	* (at least from subs) even in non-threaded perl.
401	*/
402	if (strEQ(name, "@_"))
403	return 0; /* success. (NOT_IN_PAD indicates failure) */
404	#endif /* USE_THREADS */
405
406	/* The one we're looking for is probably just before comppad_name_fill. */
407	for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
408	if ((sv = svp[off]) &&
409	sv != &PL_sv_undef &&
410	(!SvIVX(sv) \|\|
411	(seq <= SvIVX(sv) &&
412	seq > I_32(SvNVX(sv)))) &&
413	strEQ(SvPVX(sv), name))
414	{
415	if (SvIVX(sv) \|\| SvFLAGS(sv) & SVpad_OUR)
416	return (PADOFFSET)off;
417	pendoff = off; /* this pending def. will override import */
418	}
419	}
420
421	outside = CvOUTSIDE(PL_compcv);
422
423	/* Check if if we're compiling an eval'', and adjust seq to be the
424	* eval's seq number. This depends on eval'' having a non-null
425	* CvOUTSIDE() while it is being compiled. The eval'' itself is
426	* identified by CvEVAL being true and CvGV being null. */
427	if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
428	cx = &cxstack[cxstack_ix];
429	if (CxREALEVAL(cx))
430	seq = cx->blk_oldcop->cop_seq;
431	}
432
433	/* See if it's in a nested scope */
434	off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
435	if (off) {
436	/* If there is a pending local definition, this new alias must die */
437	if (pendoff)
438	SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
439	return off; /* pad_findlex returns 0 for failure...*/
440	}
441	return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */
442	}
443
444	void
445	Perl_pad_leavemy(pTHX_ I32 fill)
446	{
447	dTHR;
448	I32 off;
449	SV **svp = AvARRAY(PL_comppad_name);
450	SV *sv;
451	if (PL_min_intro_pending && fill < PL_min_intro_pending) {
452	for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
453	if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
454	Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
455	}
456	}
457	/* "Deintroduce" my variables that are leaving with this scope. */
458	for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
459	if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
460	SvIVX(sv) = PL_cop_seqmax;
461	}
462	}
463
464	PADOFFSET
465	Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
466	{
467	dTHR;
468	SV *sv;
469	I32 retval;
470
471	if (AvARRAY(PL_comppad) != PL_curpad)
472	Perl_croak(aTHX_ "panic: pad_alloc");
473	if (PL_pad_reset_pending)
474	pad_reset();
475	if (tmptype & SVs_PADMY) {
476	do {
477	sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
478	} while (SvPADBUSY(sv)); /* need a fresh one */
479	retval = AvFILLp(PL_comppad);
480	}
481	else {
482	SV **names = AvARRAY(PL_comppad_name);
483	SSize_t names_fill = AvFILLp(PL_comppad_name);
484	for (;;) {
485	/*
486	* "foreach" index vars temporarily become aliases to non-"my"
487	* values. Thus we must skip, not just pad values that are
488	* marked as current pad values, but also those with names.
489	*/
490	if (++PL_padix <= names_fill &&
491	(sv = names[PL_padix]) && sv != &PL_sv_undef)
492	continue;
493	sv = *av_fetch(PL_comppad, PL_padix, TRUE);
494	if (!(SvFLAGS(sv) & (SVs_PADTMP\|SVs_PADMY)) && !IS_PADGV(sv))
495	break;
496	}
497	retval = PL_padix;
498	}
499	SvFLAGS(sv) \|= tmptype;
500	PL_curpad = AvARRAY(PL_comppad);
501	#ifdef USE_THREADS
502	DEBUG_X(PerlIO_printf(Perl_debug_log,
503	"0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
504	PTR2UV(thr), PTR2UV(PL_curpad),
505	(long) retval, PL_op_name[optype]));
506	#else
507	DEBUG_X(PerlIO_printf(Perl_debug_log,
508	"Pad 0x%"UVxf" alloc %ld for %s\n",
509	PTR2UV(PL_curpad),
510	(long) retval, PL_op_name[optype]));
511	#endif /* USE_THREADS */
512	return (PADOFFSET)retval;
513	}
514
515	SV *
516	Perl_pad_sv(pTHX_ PADOFFSET po)
517	{
518	dTHR;
519	#ifdef USE_THREADS
520	DEBUG_X(PerlIO_printf(Perl_debug_log,
521	"0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
522	PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
523	#else
524	if (!po)
525	Perl_croak(aTHX_ "panic: pad_sv po");
526	DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
527	PTR2UV(PL_curpad), (IV)po));
528	#endif /* USE_THREADS */
529	return PL_curpad[po]; /* eventually we'll turn this into a macro */
530	}
531
532	void
533	Perl_pad_free(pTHX_ PADOFFSET po)
534	{
535	dTHR;
536	if (!PL_curpad)
537	return;
538	if (AvARRAY(PL_comppad) != PL_curpad)
539	Perl_croak(aTHX_ "panic: pad_free curpad");
540	if (!po)
541	Perl_croak(aTHX_ "panic: pad_free po");
542	#ifdef USE_THREADS
543	DEBUG_X(PerlIO_printf(Perl_debug_log,
544	"0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
545	PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
546	#else
547	DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
548	PTR2UV(PL_curpad), (IV)po));
549	#endif /* USE_THREADS */
550	if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
551	SvPADTMP_off(PL_curpad[po]);
552	#ifdef USE_ITHREADS
553	SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
554	#endif
555	}
556	if ((I32)po < PL_padix)
557	PL_padix = po - 1;
558	}
559
560	void
561	Perl_pad_swipe(pTHX_ PADOFFSET po)
562	{
563	dTHR;
564	if (AvARRAY(PL_comppad) != PL_curpad)
565	Perl_croak(aTHX_ "panic: pad_swipe curpad");
566	if (!po)
567	Perl_croak(aTHX_ "panic: pad_swipe po");
568	#ifdef USE_THREADS
569	DEBUG_X(PerlIO_printf(Perl_debug_log,
570	"0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
571	PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
572	#else
573	DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
574	PTR2UV(PL_curpad), (IV)po));
575	#endif /* USE_THREADS */
576	SvPADTMP_off(PL_curpad[po]);
577	PL_curpad[po] = NEWSV(1107,0);
578	SvPADTMP_on(PL_curpad[po]);
579	if ((I32)po < PL_padix)
580	PL_padix = po - 1;
581	}
582
583	/* XXX pad_reset() is currently disabled because it results in serious bugs.
584	* It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
585	* on the stack by OPs that use them, there are several ways to get an alias
586	* to a shared TARG. Such an alias will change randomly and unpredictably.
587	* We avoid doing this until we can think of a Better Way.
588	* GSAR 97-10-29 */
589	void
590	Perl_pad_reset(pTHX)
591	{
592	#ifdef USE_BROKEN_PAD_RESET
593	dTHR;
594	register I32 po;
595
596	if (AvARRAY(PL_comppad) != PL_curpad)
597	Perl_croak(aTHX_ "panic: pad_reset curpad");
598	#ifdef USE_THREADS
599	DEBUG_X(PerlIO_printf(Perl_debug_log,
600	"0x%"UVxf" Pad 0x%"UVxf" reset\n",
601	PTR2UV(thr), PTR2UV(PL_curpad)));
602	#else
603	DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
604	PTR2UV(PL_curpad)));
605	#endif /* USE_THREADS */
606	if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
607	for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
608	if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
609	SvPADTMP_off(PL_curpad[po]);
610	}
611	PL_padix = PL_padix_floor;
612	}
613	#endif
614	PL_pad_reset_pending = FALSE;
615	}
616
617	#ifdef USE_THREADS
618	/* find_threadsv is not reentrant */
619	PADOFFSET
620	Perl_find_threadsv(pTHX_ const char *name)
621	{
622	dTHR;
623	char *p;
624	PADOFFSET key;
625	SV **svp;
626	/* We currently only handle names of a single character */
627	p = strchr(PL_threadsv_names, *name);
628	if (!p)
629	return NOT_IN_PAD;
630	key = p - PL_threadsv_names;
631	MUTEX_LOCK(&thr->mutex);
632	svp = av_fetch(thr->threadsv, key, FALSE);
633	if (svp)
634	MUTEX_UNLOCK(&thr->mutex);
635	else {
636	SV *sv = NEWSV(0, 0);
637	av_store(thr->threadsv, key, sv);
638	thr->threadsvp = AvARRAY(thr->threadsv);
639	MUTEX_UNLOCK(&thr->mutex);
640	/*
641	* Some magic variables used to be automagically initialised
642	* in gv_fetchpv. Those which are now per-thread magicals get
643	* initialised here instead.
644	*/
645	switch (*name) {
646	case '_':
647	break;
648	case ';':
649	sv_setpv(sv, "\034");
650	sv_magic(sv, 0, 0, name, 1);
651	break;
652	case '&':
653	case '`':
654	case '\'':
655	PL_sawampersand = TRUE;
656	/* FALL THROUGH */
657	case '1':
658	case '2':
659	case '3':
660	case '4':
661	case '5':
662	case '6':
663	case '7':
664	case '8':
665	case '9':
666	SvREADONLY_on(sv);
667	/* FALL THROUGH */
668
669	/* XXX %! tied to Errno.pm needs to be added here.
670	* See gv_fetchpv(). */
671	/* case '!': */
672
673	default:
674	sv_magic(sv, 0, 0, name, 1);
675	}
676	DEBUG_S(PerlIO_printf(Perl_error_log,
677	"find_threadsv: new SV %p for $%s%c\n",
678	sv, (*name < 32) ? "^" : "",
679	(name < 32) ? toCTRL(name) : *name));
680	}
681	return key;
682	}
683	#endif /* USE_THREADS */
684
685	/* Destructor */
686
687	void
688	Perl_op_free(pTHX_ OP *o)
689	{
690	register OP kid, nextkid;
691	OPCODE type;
692
693	if (!o \|\| o->op_seq == (U16)-1)
694	return;
695
696	if (o->op_private & OPpREFCOUNTED) {
697	switch (o->op_type) {
698	case OP_LEAVESUB:
699	case OP_LEAVESUBLV:
700	case OP_LEAVEEVAL:
701	case OP_LEAVE:
702	case OP_SCOPE:
703	case OP_LEAVEWRITE:
704	OP_REFCNT_LOCK;
705	if (OpREFCNT_dec(o)) {
706	OP_REFCNT_UNLOCK;
707	return;
708	}
709	OP_REFCNT_UNLOCK;
710	break;
711	default:
712	break;
713	}
714	}
715
716	if (o->op_flags & OPf_KIDS) {
717	for (kid = cUNOPo->op_first; kid; kid = nextkid) {
718	nextkid = kid->op_sibling; /* Get before next freeing kid */
719	op_free(kid);
720	}
721	}
722	type = o->op_type;
723	if (type == OP_NULL)
724	type = o->op_targ;
725
726	/* COP* is not cleared by op_clear() so that we may track line
727	* numbers etc even after null() */
728	if (type == OP_NEXTSTATE \|\| type == OP_SETSTATE \|\| type == OP_DBSTATE)
729	cop_free((COP*)o);
730
731	op_clear(o);
732
733	#ifdef PL_OP_SLAB_ALLOC
734	if ((char *) o == PL_OpPtr)
735	{
736	}
737	#else
738	Safefree(o);
739	#endif
740	}
741
742	STATIC void
743	S_op_clear(pTHX_ OP *o)
744	{
745	switch (o->op_type) {
746	case OP_NULL: /* Was holding old type, if any. */
747	case OP_ENTEREVAL: /* Was holding hints. */
748	#ifdef USE_THREADS
749	case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
750	#endif
751	o->op_targ = 0;
752	break;
753	#ifdef USE_THREADS
754	case OP_ENTERITER:
755	if (!(o->op_flags & OPf_SPECIAL))
756	break;
757	/* FALL THROUGH */
758	#endif /* USE_THREADS */
759	default:
760	if (!(o->op_flags & OPf_REF)
761	\|\| (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
762	break;
763	/* FALL THROUGH */
764	case OP_GVSV:
765	case OP_GV:
766	case OP_AELEMFAST:
767	#ifdef USE_ITHREADS
768	if (cPADOPo->op_padix > 0) {
769	if (PL_curpad) {
770	GV *gv = cGVOPo_gv;
771	pad_swipe(cPADOPo->op_padix);
772	/* No GvIN_PAD_off(gv) here, because other references may still
773	* exist on the pad */
774	SvREFCNT_dec(gv);
775	}
776	cPADOPo->op_padix = 0;
777	}
778	#else
779	SvREFCNT_dec(cSVOPo->op_sv);
780	cSVOPo->op_sv = Nullsv;
781	#endif
782	break;
783	case OP_CONST:
784	SvREFCNT_dec(cSVOPo->op_sv);
785	cSVOPo->op_sv = Nullsv;
786	break;
787	case OP_GOTO:
788	case OP_NEXT:
789	case OP_LAST:
790	case OP_REDO:
791	if (o->op_flags & (OPf_SPECIAL\|OPf_STACKED\|OPf_KIDS))
792	break;
793	/* FALL THROUGH */
794	case OP_TRANS:
795	if (o->op_private & (OPpTRANS_FROM_UTF\|OPpTRANS_TO_UTF)) {
796	SvREFCNT_dec(cSVOPo->op_sv);
797	cSVOPo->op_sv = Nullsv;
798	}
799	else {
800	Safefree(cPVOPo->op_pv);
801	cPVOPo->op_pv = Nullch;
802	}
803	break;
804	case OP_SUBST:
805	op_free(cPMOPo->op_pmreplroot);
806	goto clear_pmop;
807	case OP_PUSHRE:
808	#ifdef USE_ITHREADS
809	if ((PADOFFSET)cPMOPo->op_pmreplroot) {
810	if (PL_curpad) {
811	GV gv = (GV)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
812	pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
813	/* No GvIN_PAD_off(gv) here, because other references may still
814	* exist on the pad */
815	SvREFCNT_dec(gv);
816	}
817	}
818	#else
819	SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
820	#endif
821	/* FALL THROUGH */
822	case OP_MATCH:
823	case OP_QR:
824	clear_pmop:
825	cPMOPo->op_pmreplroot = Nullop;
826	ReREFCNT_dec(cPMOPo->op_pmregexp);
827	cPMOPo->op_pmregexp = (REGEXP*)NULL;
828	break;
829	}
830
831	if (o->op_targ > 0) {
832	pad_free(o->op_targ);
833	o->op_targ = 0;
834	}
835	}
836
837	STATIC void
838	S_cop_free(pTHX_ COP* cop)
839	{
840	Safefree(cop->cop_label);
841	#ifdef USE_ITHREADS
842	Safefree(CopFILE(cop)); /* XXXXX share in a pvtable? */
843	Safefree(CopSTASHPV(cop)); /* XXXXX share in a pvtable? */
844	#else
845	/* NOTE: COP.cop_stash is not refcounted */
846	SvREFCNT_dec(CopFILEGV(cop));
847	#endif
848	if (! specialWARN(cop->cop_warnings))
849	SvREFCNT_dec(cop->cop_warnings);
850	}
851
852	STATIC void
853	S_null(pTHX_ OP *o)
854	{
855	if (o->op_type == OP_NULL)
856	return;
857	op_clear(o);
858	o->op_targ = o->op_type;
859	o->op_type = OP_NULL;
860	o->op_ppaddr = PL_ppaddr[OP_NULL];
861	}
862
863	/* Contextualizers */
864
865	#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
866
867	OP *
868	Perl_linklist(pTHX_ OP *o)
869	{
870	register OP *kid;
871
872	if (o->op_next)
873	return o->op_next;
874
875	/* establish postfix order */
876	if (cUNOPo->op_first) {
877	o->op_next = LINKLIST(cUNOPo->op_first);
878	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
879	if (kid->op_sibling)
880	kid->op_next = LINKLIST(kid->op_sibling);
881	else
882	kid->op_next = o;
883	}
884	}
885	else
886	o->op_next = o;
887
888	return o->op_next;
889	}
890
891	OP *
892	Perl_scalarkids(pTHX_ OP *o)
893	{
894	OP *kid;
895	if (o && o->op_flags & OPf_KIDS) {
896	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
897	scalar(kid);
898	}
899	return o;
900	}
901
902	STATIC OP *
903	S_scalarboolean(pTHX_ OP *o)
904	{
905	if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
906	dTHR;
907	if (ckWARN(WARN_SYNTAX)) {
908	line_t oldline = CopLINE(PL_curcop);
909
910	if (PL_copline != NOLINE)
911	CopLINE_set(PL_curcop, PL_copline);
912	Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
913	CopLINE_set(PL_curcop, oldline);
914	}
915	}
916	return scalar(o);
917	}
918
919	OP *
920	Perl_scalar(pTHX_ OP *o)
921	{
922	OP *kid;
923
924	/* assumes no premature commitment */
925	if (!o \|\| (o->op_flags & OPf_WANT) \|\| PL_error_count
926	\|\| o->op_type == OP_RETURN)
927	{
928	return o;
929	}
930
931	o->op_flags = (o->op_flags & ~OPf_WANT) \| OPf_WANT_SCALAR;
932
933	switch (o->op_type) {
934	case OP_REPEAT:
935	if (o->op_private & OPpREPEAT_DOLIST)
936	null(((LISTOP*)cBINOPo->op_first)->op_first);
937	scalar(cBINOPo->op_first);
938	break;
939	case OP_OR:
940	case OP_AND:
941	case OP_COND_EXPR:
942	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
943	scalar(kid);
944	break;
945	case OP_SPLIT:
946	if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
947	if (!kPMOP->op_pmreplroot)
948	deprecate("implicit split to @_");
949	}
950	/* FALL THROUGH */
951	case OP_MATCH:
952	case OP_QR:
953	case OP_SUBST:
954	case OP_NULL:
955	default:
956	if (o->op_flags & OPf_KIDS) {
957	for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
958	scalar(kid);
959	}
960	break;
961	case OP_LEAVE:
962	case OP_LEAVETRY:
963	kid = cLISTOPo->op_first;
964	scalar(kid);
965	while ((kid = kid->op_sibling)) {
966	if (kid->op_sibling)
967	scalarvoid(kid);
968	else
969	scalar(kid);
970	}
971	WITH_THR(PL_curcop = &PL_compiling);
972	break;
973	case OP_SCOPE:
974	case OP_LINESEQ:
975	case OP_LIST:
976	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
977	if (kid->op_sibling)
978	scalarvoid(kid);
979	else
980	scalar(kid);
981	}
982	WITH_THR(PL_curcop = &PL_compiling);
983	break;
984	}
985	return o;
986	}
987
988	OP *
989	Perl_scalarvoid(pTHX_ OP *o)
990	{
991	OP *kid;
992	char* useless = 0;
993	SV* sv;
994	U8 want;
995
996	if (o->op_type == OP_NEXTSTATE
997	\|\| o->op_type == OP_SETSTATE
998	\|\| o->op_type == OP_DBSTATE
999	\|\| (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1000	\|\| o->op_targ == OP_SETSTATE
1001	\|\| o->op_targ == OP_DBSTATE)))
1002	{
1003	dTHR;
1004	PL_curcop = (COP)o; / for warning below */
1005	}
1006
1007	/* assumes no premature commitment */
1008	want = o->op_flags & OPf_WANT;
1009	if ((want && want != OPf_WANT_SCALAR) \|\| PL_error_count
1010	\|\| o->op_type == OP_RETURN)
1011	{
1012	return o;
1013	}
1014
1015	if ((o->op_private & OPpTARGET_MY)
1016	&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1017	{
1018	return scalar(o); /* As if inside SASSIGN */
1019	}
1020
1021	o->op_flags = (o->op_flags & ~OPf_WANT) \| OPf_WANT_VOID;
1022
1023	switch (o->op_type) {
1024	default:
1025	if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1026	break;
1027	/* FALL THROUGH */
1028	case OP_REPEAT:
1029	if (o->op_flags & OPf_STACKED)
1030	break;
1031	goto func_ops;
1032	case OP_SUBSTR:
1033	if (o->op_private == 4)
1034	break;
1035	/* FALL THROUGH */
1036	case OP_GVSV:
1037	case OP_WANTARRAY:
1038	case OP_GV:
1039	case OP_PADSV:
1040	case OP_PADAV:
1041	case OP_PADHV:
1042	case OP_PADANY:
1043	case OP_AV2ARYLEN:
1044	case OP_REF:
1045	case OP_REFGEN:
1046	case OP_SREFGEN:
1047	case OP_DEFINED:
1048	case OP_HEX:
1049	case OP_OCT:
1050	case OP_LENGTH:
1051	case OP_VEC:
1052	case OP_INDEX:
1053	case OP_RINDEX:
1054	case OP_SPRINTF:
1055	case OP_AELEM:
1056	case OP_AELEMFAST:
1057	case OP_ASLICE:
1058	case OP_HELEM:
1059	case OP_HSLICE:
1060	case OP_UNPACK:
1061	case OP_PACK:
1062	case OP_JOIN:
1063	case OP_LSLICE:
1064	case OP_ANONLIST:
1065	case OP_ANONHASH:
1066	case OP_SORT:
1067	case OP_REVERSE:
1068	case OP_RANGE:
1069	case OP_FLIP:
1070	case OP_FLOP:
1071	case OP_CALLER:
1072	case OP_FILENO:
1073	case OP_EOF:
1074	case OP_TELL:
1075	case OP_GETSOCKNAME:
1076	case OP_GETPEERNAME:
1077	case OP_READLINK:
1078	case OP_TELLDIR:
1079	case OP_GETPPID:
1080	case OP_GETPGRP:
1081	case OP_GETPRIORITY:
1082	case OP_TIME:
1083	case OP_TMS:
1084	case OP_LOCALTIME:
1085	case OP_GMTIME:
1086	case OP_GHBYNAME:
1087	case OP_GHBYADDR:
1088	case OP_GHOSTENT:
1089	case OP_GNBYNAME:
1090	case OP_GNBYADDR:
1091	case OP_GNETENT:
1092	case OP_GPBYNAME:
1093	case OP_GPBYNUMBER:
1094	case OP_GPROTOENT:
1095	case OP_GSBYNAME:
1096	case OP_GSBYPORT:
1097	case OP_GSERVENT:
1098	case OP_GPWNAM:
1099	case OP_GPWUID:
1100	case OP_GGRNAM:
1101	case OP_GGRGID:
1102	case OP_GETLOGIN:
1103	func_ops:
1104	if (!(o->op_private & (OPpLVAL_INTRO\|OPpOUR_INTRO)))
1105	useless = PL_op_desc[o->op_type];
1106	break;
1107
1108	case OP_RV2GV:
1109	case OP_RV2SV:
1110	case OP_RV2AV:
1111	case OP_RV2HV:
1112	if (!(o->op_private & (OPpLVAL_INTRO\|OPpOUR_INTRO)) &&
1113	(!o->op_sibling \|\| o->op_sibling->op_type != OP_READLINE))
1114	useless = "a variable";
1115	break;
1116
1117	case OP_CONST:
1118	sv = cSVOPo_sv;
1119	if (cSVOPo->op_private & OPpCONST_STRICT)
1120	no_bareword_allowed(o);
1121	else {
1122	dTHR;
1123	if (ckWARN(WARN_VOID)) {
1124	useless = "a constant";
1125	if (SvNIOK(sv) && (SvNV(sv) == 0.0 \|\| SvNV(sv) == 1.0))
1126	useless = 0;
1127	else if (SvPOK(sv)) {
1128	if (strnEQ(SvPVX(sv), "di", 2) \|\|
1129	strnEQ(SvPVX(sv), "ds", 2) \|\|
1130	strnEQ(SvPVX(sv), "ig", 2))
1131	useless = 0;
1132	}
1133	}
1134	}
1135	null(o); /* don't execute or even remember it */
1136	break;
1137
1138	case OP_POSTINC:
1139	o->op_type = OP_PREINC; /* pre-increment is faster */
1140	o->op_ppaddr = PL_ppaddr[OP_PREINC];
1141	break;
1142
1143	case OP_POSTDEC:
1144	o->op_type = OP_PREDEC; /* pre-decrement is faster */
1145	o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1146	break;
1147
1148	case OP_OR:
1149	case OP_AND:
1150	case OP_COND_EXPR:
1151	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1152	scalarvoid(kid);
1153	break;
1154
1155	case OP_NULL:
1156	if (o->op_flags & OPf_STACKED)
1157	break;
1158	/* FALL THROUGH */
1159	case OP_NEXTSTATE:
1160	case OP_DBSTATE:
1161	case OP_ENTERTRY:
1162	case OP_ENTER:
1163	case OP_SCALAR:
1164	if (!(o->op_flags & OPf_KIDS))
1165	break;
1166	/* FALL THROUGH */
1167	case OP_SCOPE:
1168	case OP_LEAVE:
1169	case OP_LEAVETRY:
1170	case OP_LEAVELOOP:
1171	case OP_LINESEQ:
1172	case OP_LIST:
1173	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1174	scalarvoid(kid);
1175	break;
1176	case OP_ENTEREVAL:
1177	scalarkids(o);
1178	break;
1179	case OP_REQUIRE:
1180	/* all requires must return a boolean value */
1181	o->op_flags &= ~OPf_WANT;
1182	return scalar(o);
1183	case OP_SPLIT:
1184	if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1185	if (!kPMOP->op_pmreplroot)
1186	deprecate("implicit split to @_");
1187	}
1188	break;
1189	}
1190	if (useless) {
1191	dTHR;
1192	if (ckWARN(WARN_VOID))
1193	Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1194	}
1195	return o;
1196	}
1197
1198	OP *
1199	Perl_listkids(pTHX_ OP *o)
1200	{
1201	OP *kid;
1202	if (o && o->op_flags & OPf_KIDS) {
1203	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1204	list(kid);
1205	}
1206	return o;
1207	}
1208
1209	OP *
1210	Perl_list(pTHX_ OP *o)
1211	{
1212	OP *kid;
1213
1214	/* assumes no premature commitment */
1215	if (!o \|\| (o->op_flags & OPf_WANT) \|\| PL_error_count
1216	\|\| o->op_type == OP_RETURN)
1217	{
1218	return o;
1219	}
1220
1221	if ((o->op_private & OPpTARGET_MY)
1222	&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1223	{
1224	return o; /* As if inside SASSIGN */
1225	}
1226
1227	o->op_flags = (o->op_flags & ~OPf_WANT) \| OPf_WANT_LIST;
1228
1229	switch (o->op_type) {
1230	case OP_FLOP:
1231	case OP_REPEAT:
1232	list(cBINOPo->op_first);
1233	break;
1234	case OP_OR:
1235	case OP_AND:
1236	case OP_COND_EXPR:
1237	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1238	list(kid);
1239	break;
1240	default:
1241	case OP_MATCH:
1242	case OP_QR:
1243	case OP_SUBST:
1244	case OP_NULL:
1245	if (!(o->op_flags & OPf_KIDS))
1246	break;
1247	if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1248	list(cBINOPo->op_first);
1249	return gen_constant_list(o);
1250	}
1251	case OP_LIST:
1252	listkids(o);
1253	break;
1254	case OP_LEAVE:
1255	case OP_LEAVETRY:
1256	kid = cLISTOPo->op_first;
1257	list(kid);
1258	while ((kid = kid->op_sibling)) {
1259	if (kid->op_sibling)
1260	scalarvoid(kid);
1261	else
1262	list(kid);
1263	}
1264	WITH_THR(PL_curcop = &PL_compiling);
1265	break;
1266	case OP_SCOPE:
1267	case OP_LINESEQ:
1268	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1269	if (kid->op_sibling)
1270	scalarvoid(kid);
1271	else
1272	list(kid);
1273	}
1274	WITH_THR(PL_curcop = &PL_compiling);
1275	break;
1276	case OP_REQUIRE:
1277	/* all requires must return a boolean value */
1278	o->op_flags &= ~OPf_WANT;
1279	return scalar(o);
1280	}
1281	return o;
1282	}
1283
1284	OP *
1285	Perl_scalarseq(pTHX_ OP *o)
1286	{
1287	OP *kid;
1288
1289	if (o) {
1290	if (o->op_type == OP_LINESEQ \|\|
1291	o->op_type == OP_SCOPE \|\|
1292	o->op_type == OP_LEAVE \|\|
1293	o->op_type == OP_LEAVETRY)
1294	{
1295	dTHR;
1296	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1297	if (kid->op_sibling) {
1298	scalarvoid(kid);
1299	}
1300	}
1301	PL_curcop = &PL_compiling;
1302	}
1303	o->op_flags &= ~OPf_PARENS;
1304	if (PL_hints & HINT_BLOCK_SCOPE)
1305	o->op_flags \|= OPf_PARENS;
1306	}
1307	else
1308	o = newOP(OP_STUB, 0);
1309	return o;
1310	}
1311
1312	STATIC OP *
1313	S_modkids(pTHX_ OP *o, I32 type)
1314	{
1315	OP *kid;
1316	if (o && o->op_flags & OPf_KIDS) {
1317	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1318	mod(kid, type);
1319	}
1320	return o;
1321	}
1322
1323	OP *
1324	Perl_mod(pTHX_ OP *o, I32 type)
1325	{
1326	dTHR;
1327	OP *kid;
1328	STRLEN n_a;
1329
1330	if (!o \|\| PL_error_count)
1331	return o;
1332
1333	if ((o->op_private & OPpTARGET_MY)
1334	&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1335	{
1336	return o;
1337	}
1338
1339	switch (o->op_type) {
1340	case OP_UNDEF:
1341	PL_modcount++;
1342	return o;
1343	case OP_CONST:
1344	if (!(o->op_private & (OPpCONST_ARYBASE)))
1345	goto nomod;
1346	if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1347	PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1348	PL_eval_start = 0;
1349	}
1350	else if (!type) {
1351	SAVEI32(PL_compiling.cop_arybase);
1352	PL_compiling.cop_arybase = 0;
1353	}
1354	else if (type == OP_REFGEN)
1355	goto nomod;
1356	else
1357	Perl_croak(aTHX_ "That use of $[ is unsupported");
1358	break;
1359	case OP_STUB:
1360	if (o->op_flags & OPf_PARENS)
1361	break;
1362	goto nomod;
1363	case OP_ENTERSUB:
1364	if ((type == OP_UNDEF \|\| type == OP_REFGEN) &&
1365	!(o->op_flags & OPf_STACKED)) {
1366	o->op_type = OP_RV2CV; /* entersub => rv2cv */
1367	o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1368	assert(cUNOPo->op_first->op_type == OP_NULL);
1369	null(((LISTOP)cUNOPo->op_first)->op_first);/ disable pushmark */
1370	break;
1371	}
1372	else { /* lvalue subroutine call */
1373	o->op_private \|= OPpLVAL_INTRO;
1374	if (type == OP_GREPSTART \|\| type == OP_ENTERSUB \|\| type == OP_REFGEN) {
1375	/* Backward compatibility mode: */
1376	o->op_private \|= OPpENTERSUB_INARGS;
1377	break;
1378	}
1379	else { /* Compile-time error message: */
1380	OP *kid = cUNOPo->op_first;
1381	CV *cv;
1382	OP *okid;
1383
1384	if (kid->op_type == OP_PUSHMARK)
1385	goto skip_kids;
1386	if (kid->op_type != OP_NULL \|\| kid->op_targ != OP_LIST)
1387	Perl_croak(aTHX_
1388	"panic: unexpected lvalue entersub "
1389	"args: type/targ %ld:%ld",
1390	(long)kid->op_type,kid->op_targ);
1391	kid = kLISTOP->op_first;
1392	skip_kids:
1393	while (kid->op_sibling)
1394	kid = kid->op_sibling;
1395	if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1396	/* Indirect call */
1397	if (kid->op_type == OP_METHOD_NAMED
1398	\|\| kid->op_type == OP_METHOD)
1399	{
1400	UNOP *newop;
1401
1402	if (kid->op_sibling \|\| kid->op_next != kid) {
1403	yyerror("panic: unexpected optree near method call");
1404	break;
1405	}
1406
1407	NewOp(1101, newop, 1, UNOP);
1408	newop->op_type = OP_RV2CV;
1409	newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1410	newop->op_first = Nullop;
1411	newop->op_next = (OP*)newop;
1412	kid->op_sibling = (OP*)newop;
1413	newop->op_private \|= OPpLVAL_INTRO;
1414	break;
1415	}
1416
1417	if (kid->op_type != OP_RV2CV)
1418	Perl_croak(aTHX_
1419	"panic: unexpected lvalue entersub "
1420	"entry via type/targ %ld:%ld",
1421	(long)kid->op_type,kid->op_targ);
1422	kid->op_private \|= OPpLVAL_INTRO;
1423	break; /* Postpone until runtime */
1424	}
1425
1426	okid = kid;
1427	kid = kUNOP->op_first;
1428	if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1429	kid = kUNOP->op_first;
1430	if (kid->op_type == OP_NULL)
1431	Perl_croak(aTHX_
1432	"Unexpected constant lvalue entersub "
1433	"entry via type/targ %ld:%ld",
1434	(long)kid->op_type,kid->op_targ);
1435	if (kid->op_type != OP_GV) {
1436	/* Restore RV2CV to check lvalueness */
1437	restore_2cv:
1438	if (kid->op_next && kid->op_next != kid) { /* Happens? */
1439	okid->op_next = kid->op_next;
1440	kid->op_next = okid;
1441	}
1442	else
1443	okid->op_next = Nullop;
1444	okid->op_type = OP_RV2CV;
1445	okid->op_targ = 0;
1446	okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1447	okid->op_private \|= OPpLVAL_INTRO;
1448	break;
1449	}
1450
1451	cv = GvCV(kGVOP_gv);
1452	if (!cv)
1453	goto restore_2cv;
1454	if (CvLVALUE(cv))
1455	break;
1456	}
1457	}
1458	/* FALL THROUGH */
1459	default:
1460	nomod:
1461	/* grep, foreach, subcalls, refgen */
1462	if (type == OP_GREPSTART \|\| type == OP_ENTERSUB \|\| type == OP_REFGEN)
1463	break;
1464	yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1465	(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1466	? "do block"
1467	: (o->op_type == OP_ENTERSUB
1468	? "non-lvalue subroutine call"
1469	: PL_op_desc[o->op_type])),
1470	type ? PL_op_desc[type] : "local"));
1471	return o;
1472
1473	case OP_PREINC:
1474	case OP_PREDEC:
1475	case OP_POW:
1476	case OP_MULTIPLY:
1477	case OP_DIVIDE:
1478	case OP_MODULO:
1479	case OP_REPEAT:
1480	case OP_ADD:
1481	case OP_SUBTRACT:
1482	case OP_CONCAT:
1483	case OP_LEFT_SHIFT:
1484	case OP_RIGHT_SHIFT:
1485	case OP_BIT_AND:
1486	case OP_BIT_XOR:
1487	case OP_BIT_OR:
1488	case OP_I_MULTIPLY:
1489	case OP_I_DIVIDE:
1490	case OP_I_MODULO:
1491	case OP_I_ADD:
1492	case OP_I_SUBTRACT:
1493	if (!(o->op_flags & OPf_STACKED))
1494	goto nomod;
1495	PL_modcount++;
1496	break;
1497
1498	case OP_COND_EXPR:
1499	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1500	mod(kid, type);
1501	break;
1502
1503	case OP_RV2AV:
1504	case OP_RV2HV:
1505	if (!type && cUNOPo->op_first->op_type != OP_GV)
1506	Perl_croak(aTHX_ "Can't localize through a reference");
1507	if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1508	PL_modcount = 10000;
1509	return o; /* Treat \(@foo) like ordinary list. */
1510	}
1511	/* FALL THROUGH */
1512	case OP_RV2GV:
1513	if (scalar_mod_type(o, type))
1514	goto nomod;
1515	ref(cUNOPo->op_first, o->op_type);
1516	/* FALL THROUGH */
1517	case OP_AASSIGN:
1518	case OP_ASLICE:
1519	case OP_HSLICE:
1520	case OP_NEXTSTATE:
1521	case OP_DBSTATE:
1522	case OP_REFGEN:
1523	case OP_CHOMP:
1524	PL_modcount = 10000;
1525	break;
1526	case OP_RV2SV:
1527	if (!type && cUNOPo->op_first->op_type != OP_GV)
1528	Perl_croak(aTHX_ "Can't localize through a reference");
1529	ref(cUNOPo->op_first, o->op_type);
1530	/* FALL THROUGH */
1531	case OP_GV:
1532	case OP_AV2ARYLEN:
1533	PL_hints \|= HINT_BLOCK_SCOPE;
1534	case OP_SASSIGN:
1535	case OP_ANDASSIGN:
1536	case OP_ORASSIGN:
1537	case OP_AELEMFAST:
1538	PL_modcount++;
1539	break;
1540
1541	case OP_PADAV:
1542	case OP_PADHV:
1543	PL_modcount = 10000;
1544	if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1545	return o; /* Treat \(@foo) like ordinary list. */
1546	if (scalar_mod_type(o, type))
1547	goto nomod;
1548	/* FALL THROUGH */
1549	case OP_PADSV:
1550	PL_modcount++;
1551	if (!type)
1552	Perl_croak(aTHX_ "Can't localize lexical variable %s",
1553	SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1554	break;
1555
1556	#ifdef USE_THREADS
1557	case OP_THREADSV:
1558	PL_modcount++; /* XXX ??? */
1559	break;
1560	#endif /* USE_THREADS */
1561
1562	case OP_PUSHMARK:
1563	break;
1564
1565	case OP_KEYS:
1566	if (type != OP_SASSIGN)
1567	goto nomod;
1568	goto lvalue_func;
1569	case OP_SUBSTR:
1570	if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1571	goto nomod;
1572	/* FALL THROUGH */
1573	case OP_POS:
1574	case OP_VEC:
1575	lvalue_func:
1576	pad_free(o->op_targ);
1577	o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1578	assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1579	if (o->op_flags & OPf_KIDS)
1580	mod(cBINOPo->op_first->op_sibling, type);
1581	break;
1582
1583	case OP_AELEM:
1584	case OP_HELEM:
1585	ref(cBINOPo->op_first, o->op_type);
1586	if (type == OP_ENTERSUB &&
1587	!(o->op_private & (OPpLVAL_INTRO \| OPpDEREF)))
1588	o->op_private \|= OPpLVAL_DEFER;
1589	PL_modcount++;
1590	break;
1591
1592	case OP_SCOPE:
1593	case OP_LEAVE:
1594	case OP_ENTER:
1595	if (o->op_flags & OPf_KIDS)
1596	mod(cLISTOPo->op_last, type);
1597	break;
1598
1599	case OP_NULL:
1600	if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1601	goto nomod;
1602	else if (!(o->op_flags & OPf_KIDS))
1603	break;
1604	if (o->op_targ != OP_LIST) {
1605	mod(cBINOPo->op_first, type);
1606	break;
1607	}
1608	/* FALL THROUGH */
1609	case OP_LIST:
1610	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1611	mod(kid, type);
1612	break;
1613	}
1614	o->op_flags \|= OPf_MOD;
1615
1616	if (type == OP_AASSIGN \|\| type == OP_SASSIGN)
1617	o->op_flags \|= OPf_SPECIAL\|OPf_REF;
1618	else if (!type) {
1619	o->op_private \|= OPpLVAL_INTRO;
1620	o->op_flags &= ~OPf_SPECIAL;
1621	PL_hints \|= HINT_BLOCK_SCOPE;
1622	}
1623	else if (type != OP_GREPSTART && type != OP_ENTERSUB)
1624	o->op_flags \|= OPf_REF;
1625	return o;
1626	}
1627
1628	STATIC bool
1629	S_scalar_mod_type(pTHX_ OP *o, I32 type)
1630	{
1631	switch (type) {
1632	case OP_SASSIGN:
1633	if (o->op_type == OP_RV2GV)
1634	return FALSE;
1635	/* FALL THROUGH */
1636	case OP_PREINC:
1637	case OP_PREDEC:
1638	case OP_POSTINC:
1639	case OP_POSTDEC:
1640	case OP_I_PREINC:
1641	case OP_I_PREDEC:
1642	case OP_I_POSTINC:
1643	case OP_I_POSTDEC:
1644	case OP_POW:
1645	case OP_MULTIPLY:
1646	case OP_DIVIDE:
1647	case OP_MODULO:
1648	case OP_REPEAT:
1649	case OP_ADD:
1650	case OP_SUBTRACT:
1651	case OP_I_MULTIPLY:
1652	case OP_I_DIVIDE:
1653	case OP_I_MODULO:
1654	case OP_I_ADD:
1655	case OP_I_SUBTRACT:
1656	case OP_LEFT_SHIFT:
1657	case OP_RIGHT_SHIFT:
1658	case OP_BIT_AND:
1659	case OP_BIT_XOR:
1660	case OP_BIT_OR:
1661	case OP_CONCAT:
1662	case OP_SUBST:
1663	case OP_TRANS:
1664	case OP_READ:
1665	case OP_SYSREAD:
1666	case OP_RECV:
1667	case OP_ANDASSIGN:
1668	case OP_ORASSIGN:
1669	return TRUE;
1670	default:
1671	return FALSE;
1672	}
1673	}
1674
1675	STATIC bool
1676	S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1677	{
1678	switch (o->op_type) {
1679	case OP_PIPE_OP:
1680	case OP_SOCKPAIR:
1681	if (argnum == 2)
1682	return TRUE;
1683	/* FALL THROUGH */
1684	case OP_SYSOPEN:
1685	case OP_OPEN:
1686	case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1687	case OP_SOCKET:
1688	case OP_OPEN_DIR:
1689	case OP_ACCEPT:
1690	if (argnum == 1)
1691	return TRUE;
1692	/* FALL THROUGH */
1693	default:
1694	return FALSE;
1695	}
1696	}
1697
1698	OP *
1699	Perl_refkids(pTHX_ OP *o, I32 type)
1700	{
1701	OP *kid;
1702	if (o && o->op_flags & OPf_KIDS) {
1703	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1704	ref(kid, type);
1705	}
1706	return o;
1707	}
1708
1709	OP *
1710	Perl_ref(pTHX_ OP *o, I32 type)
1711	{
1712	OP *kid;
1713
1714	if (!o \|\| PL_error_count)
1715	return o;
1716
1717	switch (o->op_type) {
1718	case OP_ENTERSUB:
1719	if ((type == OP_EXISTS \|\| type == OP_DEFINED \|\| type == OP_LOCK) &&
1720	!(o->op_flags & OPf_STACKED)) {
1721	o->op_type = OP_RV2CV; /* entersub => rv2cv */
1722	o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1723	assert(cUNOPo->op_first->op_type == OP_NULL);
1724	null(((LISTOP)cUNOPo->op_first)->op_first); / disable pushmark */
1725	o->op_flags \|= OPf_SPECIAL;
1726	}
1727	break;
1728
1729	case OP_COND_EXPR:
1730	for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1731	ref(kid, type);
1732	break;
1733	case OP_RV2SV:
1734	if (type == OP_DEFINED)
1735	o->op_flags \|= OPf_SPECIAL; /* don't create GV */
1736	ref(cUNOPo->op_first, o->op_type);
1737	/* FALL THROUGH */
1738	case OP_PADSV:
1739	if (type == OP_RV2SV \|\| type == OP_RV2AV \|\| type == OP_RV2HV) {
1740	o->op_private \|= (type == OP_RV2AV ? OPpDEREF_AV
1741	: type == OP_RV2HV ? OPpDEREF_HV
1742	: OPpDEREF_SV);
1743	o->op_flags \|= OPf_MOD;
1744	}
1745	break;
1746
1747	case OP_THREADSV:
1748	o->op_flags \|= OPf_MOD; /* XXX ??? */
1749	break;
1750
1751	case OP_RV2AV:
1752	case OP_RV2HV:
1753	o->op_flags \|= OPf_REF;
1754	/* FALL THROUGH */
1755	case OP_RV2GV:
1756	if (type == OP_DEFINED)
1757	o->op_flags \|= OPf_SPECIAL; /* don't create GV */
1758	ref(cUNOPo->op_first, o->op_type);
1759	break;
1760
1761	case OP_PADAV:
1762	case OP_PADHV:
1763	o->op_flags \|= OPf_REF;
1764	break;
1765
1766	case OP_SCALAR:
1767	case OP_NULL:
1768	if (!(o->op_flags & OPf_KIDS))
1769	break;
1770	ref(cBINOPo->op_first, type);
1771	break;
1772	case OP_AELEM:
1773	case OP_HELEM:
1774	ref(cBINOPo->op_first, o->op_type);
1775	if (type == OP_RV2SV \|\| type == OP_RV2AV \|\| type == OP_RV2HV) {
1776	o->op_private \|= (type == OP_RV2AV ? OPpDEREF_AV
1777	: type == OP_RV2HV ? OPpDEREF_HV
1778	: OPpDEREF_SV);
1779	o->op_flags \|= OPf_MOD;
1780	}
1781	break;
1782
1783	case OP_SCOPE:
1784	case OP_LEAVE:
1785	case OP_ENTER:
1786	case OP_LIST:
1787	if (!(o->op_flags & OPf_KIDS))
1788	break;
1789	ref(cLISTOPo->op_last, type);
1790	break;
1791	default:
1792	break;
1793	}
1794	return scalar(o);
1795
1796	}
1797
1798	STATIC OP *
1799	S_dup_attrlist(pTHX_ OP *o)
1800	{
1801	OP *rop = Nullop;
1802
1803	/* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1804	* where the first kid is OP_PUSHMARK and the remaining ones
1805	* are OP_CONST. We need to push the OP_CONST values.
1806	*/
1807	if (o->op_type == OP_CONST)
1808	rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1809	else {
1810	assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1811	for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1812	if (o->op_type == OP_CONST)
1813	rop = append_elem(OP_LIST, rop,
1814	newSVOP(OP_CONST, o->op_flags,
1815	SvREFCNT_inc(cSVOPo->op_sv)));
1816	}
1817	}
1818	return rop;
1819	}
1820
1821	STATIC void
1822	S_apply_attrs(pTHX_ HV stash, SV target, OP *attrs)
1823	{
1824	SV *stashsv;
1825
1826	/* fake up C<use attributes $pkg,$rv,@attrs> */
1827	ENTER; /* need to protect against side-effects of 'use' */
1828	SAVEINT(PL_expect);
1829	if (stash && HvNAME(stash))
1830	stashsv = newSVpv(HvNAME(stash), 0);
1831	else
1832	stashsv = &PL_sv_no;
1833
1834	#define ATTRSMODULE "attributes"
1835
1836	Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1837	newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1838	Nullsv,
1839	prepend_elem(OP_LIST,
1840	newSVOP(OP_CONST, 0, stashsv),
1841	prepend_elem(OP_LIST,
1842	newSVOP(OP_CONST, 0,
1843	newRV(target)),
1844	dup_attrlist(attrs))));
1845	LEAVE;
1846	}
1847
1848	STATIC OP *
1849	S_my_kid(pTHX_ OP o, OP attrs)
1850	{
1851	OP *kid;
1852	I32 type;
1853
1854	if (!o \|\| PL_error_count)
1855	return o;
1856
1857	type = o->op_type;
1858	if (type == OP_LIST) {
1859	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1860	my_kid(kid, attrs);
1861	} else if (type == OP_UNDEF) {
1862	return o;
1863	} else if (type == OP_RV2SV \|\| /* "our" declaration */
1864	type == OP_RV2AV \|\|
1865	type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1866	o->op_private \|= OPpOUR_INTRO;
1867	return o;
1868	} else if (type != OP_PADSV &&
1869	type != OP_PADAV &&
1870	type != OP_PADHV &&
1871	type != OP_PUSHMARK)
1872	{
1873	yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1874	PL_op_desc[o->op_type],
1875	PL_in_my == KEY_our ? "our" : "my"));
1876	return o;
1877	}
1878	else if (attrs && type != OP_PUSHMARK) {
1879	HV *stash;
1880	SV *padsv;
1881	SV **namesvp;
1882
1883	PL_in_my = FALSE;
1884	PL_in_my_stash = Nullhv;
1885
1886	/* check for C<my Dog $spot> when deciding package */
1887	namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1888	if (namesvp && namesvp && SvOBJECT(namesvp) && HvNAME(SvSTASH(*namesvp)))
1889	stash = SvSTASH(*namesvp);
1890	else
1891	stash = PL_curstash;
1892	padsv = PAD_SV(o->op_targ);
1893	apply_attrs(stash, padsv, attrs);
1894	}
1895	o->op_flags \|= OPf_MOD;
1896	o->op_private \|= OPpLVAL_INTRO;
1897	return o;
1898	}
1899
1900	OP *
1901	Perl_my_attrs(pTHX_ OP o, OP attrs)
1902	{
1903	if (o->op_flags & OPf_PARENS)
1904	list(o);
1905	if (attrs)
1906	SAVEFREEOP(attrs);
1907	o = my_kid(o, attrs);
1908	PL_in_my = FALSE;
1909	PL_in_my_stash = Nullhv;
1910	return o;
1911	}
1912
1913	OP *
1914	Perl_my(pTHX_ OP *o)
1915	{
1916	return my_kid(o, Nullop);
1917	}
1918
1919	OP *
1920	Perl_sawparens(pTHX_ OP *o)
1921	{
1922	if (o)
1923	o->op_flags \|= OPf_PARENS;
1924	return o;
1925	}
1926
1927	OP *
1928	Perl_bind_match(pTHX_ I32 type, OP left, OP right)
1929	{
1930	dTHR;
1931	OP *o;
1932
1933	if (ckWARN(WARN_MISC) &&
1934	(left->op_type == OP_RV2AV \|\|
1935	left->op_type == OP_RV2HV \|\|
1936	left->op_type == OP_PADAV \|\|
1937	left->op_type == OP_PADHV)) {
1938	char *desc = PL_op_desc[(right->op_type == OP_SUBST \|\|
1939	right->op_type == OP_TRANS)
1940	? right->op_type : OP_MATCH];
1941	const char *sample = ((left->op_type == OP_RV2AV \|\|
1942	left->op_type == OP_PADAV)
1943	? "@array" : "%hash");
1944	Perl_warner(aTHX_ WARN_MISC,
1945	"Applying %s to %s will act on scalar(%s)",
1946	desc, sample, sample);
1947	}
1948
1949	if (right->op_type == OP_MATCH \|\|
1950	right->op_type == OP_SUBST \|\|
1951	right->op_type == OP_TRANS) {
1952	right->op_flags \|= OPf_STACKED;
1953	if (right->op_type != OP_MATCH)
1954	left = mod(left, right->op_type);
1955	if (right->op_type == OP_TRANS)
1956	o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1957	else
1958	o = prepend_elem(right->op_type, scalar(left), right);
1959	if (type == OP_NOT)
1960	return newUNOP(OP_NOT, 0, scalar(o));
1961	return o;
1962	}
1963	else
1964	return bind_match(type, left,
1965	pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1966	}
1967
1968	OP *
1969	Perl_invert(pTHX_ OP *o)
1970	{
1971	if (!o)
1972	return o;
1973	/* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1974	return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1975	}
1976
1977	OP *
1978	Perl_scope(pTHX_ OP *o)
1979	{
1980	if (o) {
1981	if (o->op_flags & OPf_PARENS \|\| PERLDB_NOOPT \|\| PL_tainting) {
1982	o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1983	o->op_type = OP_LEAVE;
1984	o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1985	}
1986	else {
1987	if (o->op_type == OP_LINESEQ) {
1988	OP *kid;
1989	o->op_type = OP_SCOPE;
1990	o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1991	kid = ((LISTOP*)o)->op_first;
1992	if (kid->op_type == OP_NEXTSTATE \|\| kid->op_type == OP_DBSTATE)
1993	null(kid);
1994	}
1995	else
1996	o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1997	}
1998	}
1999	return o;
2000	}
2001
2002	void
2003	Perl_save_hints(pTHX)
2004	{
2005	SAVEI32(PL_hints);
2006	SAVESPTR(GvHV(PL_hintgv));
2007	GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2008	SAVEFREESV(GvHV(PL_hintgv));
2009	}
2010
2011	int
2012	Perl_block_start(pTHX_ int full)
2013	{
2014	dTHR;
2015	int retval = PL_savestack_ix;
2016
2017	SAVEI32(PL_comppad_name_floor);
2018	PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2019	if (full)
2020	PL_comppad_name_fill = PL_comppad_name_floor;
2021	if (PL_comppad_name_floor < 0)
2022	PL_comppad_name_floor = 0;
2023	SAVEI32(PL_min_intro_pending);
2024	SAVEI32(PL_max_intro_pending);
2025	PL_min_intro_pending = 0;
2026	SAVEI32(PL_comppad_name_fill);
2027	SAVEI32(PL_padix_floor);
2028	PL_padix_floor = PL_padix;
2029	PL_pad_reset_pending = FALSE;
2030	SAVEHINTS();
2031	PL_hints &= ~HINT_BLOCK_SCOPE;
2032	SAVESPTR(PL_compiling.cop_warnings);
2033	if (! specialWARN(PL_compiling.cop_warnings)) {
2034	PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2035	SAVEFREESV(PL_compiling.cop_warnings) ;
2036	}
2037	return retval;
2038	}
2039
2040	OP*
2041	Perl_block_end(pTHX_ I32 floor, OP *seq)
2042	{
2043	dTHR;
2044	int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2045	OP* retval = scalarseq(seq);
2046	LEAVE_SCOPE(floor);
2047	PL_pad_reset_pending = FALSE;
2048	PL_compiling.op_private = PL_hints;
2049	if (needblockscope)
2050	PL_hints \|= HINT_BLOCK_SCOPE; /* propagate out */
2051	pad_leavemy(PL_comppad_name_fill);
2052	PL_cop_seqmax++;
2053	return retval;
2054	}
2055
2056	STATIC OP *
2057	S_newDEFSVOP(pTHX)
2058	{
2059	#ifdef USE_THREADS
2060	OP *o = newOP(OP_THREADSV, 0);
2061	o->op_targ = find_threadsv("_");
2062	return o;
2063	#else
2064	return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2065	#endif /* USE_THREADS */
2066	}
2067
2068	void
2069	Perl_newPROG(pTHX_ OP *o)
2070	{
2071	dTHR;
2072	if (PL_in_eval) {
2073	if (PL_eval_root)
2074	return;
2075	PL_eval_root = newUNOP(OP_LEAVEEVAL,
2076	((PL_in_eval & EVAL_KEEPERR)
2077	? OPf_SPECIAL : 0), o);
2078	PL_eval_start = linklist(PL_eval_root);
2079	PL_eval_root->op_private \|= OPpREFCOUNTED;
2080	OpREFCNT_set(PL_eval_root, 1);
2081	PL_eval_root->op_next = 0;
2082	peep(PL_eval_start);
2083	}
2084	else {
2085	if (!o)
2086	return;
2087	PL_main_root = scope(sawparens(scalarvoid(o)));
2088	PL_curcop = &PL_compiling;
2089	PL_main_start = LINKLIST(PL_main_root);
2090	PL_main_root->op_private \|= OPpREFCOUNTED;
2091	OpREFCNT_set(PL_main_root, 1);
2092	PL_main_root->op_next = 0;
2093	peep(PL_main_start);
2094	PL_compcv = 0;
2095
2096	/* Register with debugger */
2097	if (PERLDB_INTER) {
2098	CV *cv = get_cv("DB::postponed", FALSE);
2099	if (cv) {
2100	dSP;
2101	PUSHMARK(SP);
2102	XPUSHs((SV*)CopFILEGV(&PL_compiling));
2103	PUTBACK;
2104	call_sv((SV*)cv, G_DISCARD);
2105	}
2106	}
2107	}
2108	}
2109
2110	OP *
2111	Perl_localize(pTHX_ OP *o, I32 lex)
2112	{
2113	if (o->op_flags & OPf_PARENS)
2114	list(o);
2115	else {
2116	dTHR;
2117	if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2118	char *s;
2119	for (s = PL_bufptr; s && (isALNUM(s) \|\| (s & 0x80) \|\| strchr("@$%, ",s)); s++) ;
2120	if (s == ';' \|\| s == '=')
2121	Perl_warner(aTHX_ WARN_PARENTHESIS,
2122	"Parentheses missing around \"%s\" list",
2123	lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2124	}
2125	}
2126	if (lex)
2127	o = my(o);
2128	else
2129	o = mod(o, OP_NULL); /* a bit kludgey */
2130	PL_in_my = FALSE;
2131	PL_in_my_stash = Nullhv;
2132	return o;
2133	}
2134
2135	OP *
2136	Perl_jmaybe(pTHX_ OP *o)
2137	{
2138	if (o->op_type == OP_LIST) {
2139	OP *o2;
2140	#ifdef USE_THREADS
2141	o2 = newOP(OP_THREADSV, 0);
2142	o2->op_targ = find_threadsv(";");
2143	#else
2144	o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2145	#endif /* USE_THREADS */
2146	o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2147	}
2148	return o;
2149	}
2150
2151	OP *
2152	Perl_fold_constants(pTHX_ register OP *o)
2153	{
2154	dTHR;
2155	register OP *curop;
2156	I32 type = o->op_type;
2157	SV *sv;
2158
2159	if (PL_opargs[type] & OA_RETSCALAR)
2160	scalar(o);
2161	if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2162	o->op_targ = pad_alloc(type, SVs_PADTMP);
2163
2164	/* integerize op, unless it happens to be C<-foo>.
2165	* XXX should pp_i_negate() do magic string negation instead? */
2166	if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2167	&& !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2168	&& (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2169	{
2170	o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2171	}
2172
2173	if (!(PL_opargs[type] & OA_FOLDCONST))
2174	goto nope;
2175
2176	switch (type) {
2177	case OP_NEGATE:
2178	/* XXX might want a ck_negate() for this */
2179	cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2180	break;
2181	case OP_SPRINTF:
2182	case OP_UCFIRST:
2183	case OP_LCFIRST:
2184	case OP_UC:
2185	case OP_LC:
2186	case OP_SLT:
2187	case OP_SGT:
2188	case OP_SLE:
2189	case OP_SGE:
2190	case OP_SCMP:
2191
2192	if (o->op_private & OPpLOCALE)
2193	goto nope;
2194	}
2195
2196	if (PL_error_count)
2197	goto nope; /* Don't try to run w/ errors */
2198
2199	for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2200	if ((curop->op_type != OP_CONST \|\|
2201	(curop->op_private & OPpCONST_BARE)) &&
2202	curop->op_type != OP_LIST &&
2203	curop->op_type != OP_SCALAR &&
2204	curop->op_type != OP_NULL &&
2205	curop->op_type != OP_PUSHMARK)
2206	{
2207	goto nope;
2208	}
2209	}
2210
2211	curop = LINKLIST(o);
2212	o->op_next = 0;
2213	PL_op = curop;
2214	CALLRUNOPS(aTHX);
2215	sv = *(PL_stack_sp--);
2216	if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2217	pad_swipe(o->op_targ);
2218	else if (SvTEMP(sv)) { /* grab mortal temp? */
2219	(void)SvREFCNT_inc(sv);
2220	SvTEMP_off(sv);
2221	}
2222	op_free(o);
2223	if (type == OP_RV2GV)
2224	return newGVOP(OP_GV, 0, (GV*)sv);
2225	else {
2226	/* try to smush double to int, but don't smush -2.0 to -2 */
2227	if ((SvFLAGS(sv) & (SVf_IOK\|SVf_NOK\|SVf_POK)) == SVf_NOK &&
2228	type != OP_NEGATE)
2229	{
2230	IV iv = SvIV(sv);
2231	if ((NV)iv == SvNV(sv)) {
2232	SvREFCNT_dec(sv);
2233	sv = newSViv(iv);
2234	}
2235	else
2236	SvIOK_off(sv); /* undo SvIV() damage */
2237	}
2238	return newSVOP(OP_CONST, 0, sv);
2239	}
2240
2241	nope:
2242	if (!(PL_opargs[type] & OA_OTHERINT))
2243	return o;
2244
2245	if (!(PL_hints & HINT_INTEGER)) {
2246	if (type == OP_MODULO
2247	\|\| type == OP_DIVIDE
2248	\|\| !(o->op_flags & OPf_KIDS))
2249	{
2250	return o;
2251	}
2252
2253	for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2254	if (curop->op_type == OP_CONST) {
2255	if (SvIOK(((SVOP*)curop)->op_sv))
2256	continue;
2257	return o;
2258	}
2259	if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2260	continue;
2261	return o;
2262	}
2263	o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2264	}
2265
2266	return o;
2267	}
2268
2269	OP *
2270	Perl_gen_constant_list(pTHX_ register OP *o)
2271	{
2272	dTHR;
2273	register OP *curop;
2274	I32 oldtmps_floor = PL_tmps_floor;
2275
2276	list(o);
2277	if (PL_error_count)
2278	return o; /* Don't attempt to run with errors */
2279
2280	PL_op = curop = LINKLIST(o);
2281	o->op_next = 0;
2282	peep(curop);
2283	pp_pushmark();
2284	CALLRUNOPS(aTHX);
2285	PL_op = curop;
2286	pp_anonlist();
2287	PL_tmps_floor = oldtmps_floor;
2288
2289	o->op_type = OP_RV2AV;
2290	o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2291	curop = ((UNOP*)o)->op_first;
2292	((UNOP)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(PL_stack_sp--));
2293	op_free(curop);
2294	linklist(o);
2295	return list(o);
2296	}
2297
2298	OP *
2299	Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2300	{
2301	OP *kid;
2302	OP *last = 0;
2303
2304	if (!o \|\| o->op_type != OP_LIST)
2305	o = newLISTOP(OP_LIST, 0, o, Nullop);
2306	else
2307	o->op_flags &= ~OPf_WANT;
2308
2309	if (!(PL_opargs[type] & OA_MARK))
2310	null(cLISTOPo->op_first);
2311
2312	o->op_type = type;
2313	o->op_ppaddr = PL_ppaddr[type];
2314	o->op_flags \|= flags;
2315
2316	o = CHECKOP(type, o);
2317	if (o->op_type != type)
2318	return o;
2319
2320	if (cLISTOPo->op_children < 7) {
2321	/* XXX do we really need to do this if we're done appending?? */
2322	for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2323	last = kid;
2324	cLISTOPo->op_last = last; /* in case check substituted last arg */
2325	}
2326
2327	return fold_constants(o);
2328	}
2329
2330	/* List constructors */
2331
2332	OP *
2333	Perl_append_elem(pTHX_ I32 type, OP first, OP last)
2334	{
2335	if (!first)
2336	return last;
2337
2338	if (!last)
2339	return first;
2340
2341	if (first->op_type != type
2342	\|\| (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2343	{
2344	return newLISTOP(type, 0, first, last);
2345	}
2346
2347	if (first->op_flags & OPf_KIDS)
2348	((LISTOP*)first)->op_last->op_sibling = last;
2349	else {
2350	first->op_flags \|= OPf_KIDS;
2351	((LISTOP*)first)->op_first = last;
2352	}
2353	((LISTOP*)first)->op_last = last;
2354	((LISTOP*)first)->op_children++;
2355	return first;
2356	}
2357
2358	OP *
2359	Perl_append_list(pTHX_ I32 type, LISTOP first, LISTOP last)
2360	{
2361	if (!first)
2362	return (OP*)last;
2363
2364	if (!last)
2365	return (OP*)first;
2366
2367	if (first->op_type != type)
2368	return prepend_elem(type, (OP)first, (OP)last);
2369
2370	if (last->op_type != type)
2371	return append_elem(type, (OP)first, (OP)last);
2372
2373	first->op_last->op_sibling = last->op_first;
2374	first->op_last = last->op_last;
2375	first->op_children += last->op_children;
2376	if (first->op_children)
2377	first->op_flags \|= OPf_KIDS;
2378
2379	#ifdef PL_OP_SLAB_ALLOC
2380	#else
2381	Safefree(last);
2382	#endif
2383	return (OP*)first;
2384	}
2385
2386	OP *
2387	Perl_prepend_elem(pTHX_ I32 type, OP first, OP last)
2388	{
2389	if (!first)
2390	return last;
2391
2392	if (!last)
2393	return first;
2394
2395	if (last->op_type == type) {
2396	if (type == OP_LIST) { /* already a PUSHMARK there */
2397	first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2398	((LISTOP*)last)->op_first->op_sibling = first;
2399	}
2400	else {
2401	if (!(last->op_flags & OPf_KIDS)) {
2402	((LISTOP*)last)->op_last = first;
2403	last->op_flags \|= OPf_KIDS;
2404	}
2405	first->op_sibling = ((LISTOP*)last)->op_first;
2406	((LISTOP*)last)->op_first = first;
2407	}
2408	((LISTOP*)last)->op_children++;
2409	return last;
2410	}
2411
2412	return newLISTOP(type, 0, first, last);
2413	}
2414
2415	/* Constructors */
2416
2417	OP *
2418	Perl_newNULLLIST(pTHX)
2419	{
2420	return newOP(OP_STUB, 0);
2421	}
2422
2423	OP *
2424	Perl_force_list(pTHX_ OP *o)
2425	{
2426	if (!o \|\| o->op_type != OP_LIST)
2427	o = newLISTOP(OP_LIST, 0, o, Nullop);
2428	null(o);
2429	return o;
2430	}
2431
2432	OP *
2433	Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP first, OP last)
2434	{
2435	LISTOP *listop;
2436
2437	NewOp(1101, listop, 1, LISTOP);
2438
2439	listop->op_type = type;
2440	listop->op_ppaddr = PL_ppaddr[type];
2441	listop->op_children = (first != 0) + (last != 0);
2442	listop->op_flags = flags;
2443
2444	if (!last && first)
2445	last = first;
2446	else if (!first && last)
2447	first = last;
2448	else if (first)
2449	first->op_sibling = last;
2450	listop->op_first = first;
2451	listop->op_last = last;
2452	if (type == OP_LIST) {
2453	OP* pushop;
2454	pushop = newOP(OP_PUSHMARK, 0);
2455	pushop->op_sibling = first;
2456	listop->op_first = pushop;
2457	listop->op_flags \|= OPf_KIDS;
2458	if (!last)
2459	listop->op_last = pushop;
2460	}
2461	else if (listop->op_children)
2462	listop->op_flags \|= OPf_KIDS;
2463
2464	return (OP*)listop;
2465	}
2466
2467	OP *
2468	Perl_newOP(pTHX_ I32 type, I32 flags)
2469	{
2470	OP *o;
2471	NewOp(1101, o, 1, OP);
2472	o->op_type = type;
2473	o->op_ppaddr = PL_ppaddr[type];
2474	o->op_flags = flags;
2475
2476	o->op_next = o;
2477	o->op_private = 0 + (flags >> 8);
2478	if (PL_opargs[type] & OA_RETSCALAR)
2479	scalar(o);
2480	if (PL_opargs[type] & OA_TARGET)
2481	o->op_targ = pad_alloc(type, SVs_PADTMP);
2482	return CHECKOP(type, o);
2483	}
2484
2485	OP *
2486	Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2487	{
2488	UNOP *unop;
2489
2490	if (!first)
2491	first = newOP(OP_STUB, 0);
2492	if (PL_opargs[type] & OA_MARK)
2493	first = force_list(first);
2494
2495	NewOp(1101, unop, 1, UNOP);
2496	unop->op_type = type;
2497	unop->op_ppaddr = PL_ppaddr[type];
2498	unop->op_first = first;
2499	unop->op_flags = flags \| OPf_KIDS;
2500	unop->op_private = 1 \| (flags >> 8);
2501	unop = (UNOP*) CHECKOP(type, unop);
2502	if (unop->op_next)
2503	return (OP*)unop;
2504
2505	return fold_constants((OP *) unop);
2506	}
2507
2508	OP *
2509	Perl_newBINOP(pTHX_ I32 type, I32 flags, OP first, OP last)
2510	{
2511	BINOP *binop;
2512	NewOp(1101, binop, 1, BINOP);
2513
2514	if (!first)
2515	first = newOP(OP_NULL, 0);
2516
2517	binop->op_type = type;
2518	binop->op_ppaddr = PL_ppaddr[type];
2519	binop->op_first = first;
2520	binop->op_flags = flags \| OPf_KIDS;
2521	if (!last) {
2522	last = first;
2523	binop->op_private = 1 \| (flags >> 8);
2524	}
2525	else {
2526	binop->op_private = 2 \| (flags >> 8);
2527	first->op_sibling = last;
2528	}
2529
2530	binop = (BINOP*)CHECKOP(type, binop);
2531	if (binop->op_next \|\| binop->op_type != type)
2532	return (OP*)binop;
2533
2534	binop->op_last = binop->op_first->op_sibling;
2535
2536	return fold_constants((OP *)binop);
2537	}
2538
2539	static int
2540	utf8compare(const void a, const void b)
2541	{
2542	int i;
2543	for (i = 0; i < 10; i++) {
2544	if (((U8)a)[i] < ((U8**)b)[i])
2545	return -1;
2546	if (((U8)a)[i] > ((U8**)b)[i])
2547	return 1;
2548	}
2549	return 0;
2550	}
2551
2552	OP *
2553	Perl_pmtrans(pTHX_ OP o, OP expr, OP *repl)
2554	{
2555	SV tstr = ((SVOP)expr)->op_sv;
2556	SV rstr = ((SVOP)repl)->op_sv;
2557	STRLEN tlen;
2558	STRLEN rlen;
2559	register U8 t = (U8)SvPV(tstr, tlen);
2560	register U8 r = (U8)SvPV(rstr, rlen);
2561	register I32 i;
2562	register I32 j;
2563	I32 del;
2564	I32 complement;
2565	I32 squash;
2566	register short *tbl;
2567
2568	complement = o->op_private & OPpTRANS_COMPLEMENT;
2569	del = o->op_private & OPpTRANS_DELETE;
2570	squash = o->op_private & OPpTRANS_SQUASH;
2571
2572	if (o->op_private & (OPpTRANS_FROM_UTF\|OPpTRANS_TO_UTF)) {
2573	SV* listsv = newSVpvn("# comment\n",10);
2574	SV* transv = 0;
2575	U8* tend = t + tlen;
2576	U8* rend = r + rlen;
2577	I32 ulen;
2578	U32 tfirst = 1;
2579	U32 tlast = 0;
2580	I32 tdiff;
2581	U32 rfirst = 1;
2582	U32 rlast = 0;
2583	I32 rdiff;
2584	I32 diff;
2585	I32 none = 0;
2586	U32 max = 0;
2587	I32 bits;
2588	I32 grows = 0;
2589	I32 havefinal = 0;
2590	U32 final;
2591	I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2592	I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2593
2594	if (complement) {
2595	U8 tmpbuf[UTF8_MAXLEN];
2596	U8** cp;
2597	UV nextmin = 0;
2598	New(1109, cp, tlen, U8*);
2599	i = 0;
2600	transv = newSVpvn("",0);
2601	while (t < tend) {
2602	cp[i++] = t;
2603	t += UTF8SKIP(t);
2604	if (*t == 0xff) {
2605	t++;
2606	t += UTF8SKIP(t);
2607	}
2608	}
2609	qsort(cp, i, sizeof(U8*), utf8compare);
2610	for (j = 0; j < i; j++) {
2611	U8 *s = cp[j];
2612	UV val = utf8_to_uv(s, &ulen);
2613	s += ulen;
2614	diff = val - nextmin;
2615	if (diff > 0) {
2616	t = uv_to_utf8(tmpbuf,nextmin);
2617	sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2618	if (diff > 1) {
2619	t = uv_to_utf8(tmpbuf, val - 1);
2620	sv_catpvn(transv, "\377", 1);
2621	sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2622	}
2623	}
2624	if (*s == 0xff)
2625	val = utf8_to_uv(s+1, &ulen);
2626	if (val >= nextmin)
2627	nextmin = val + 1;
2628	}
2629	t = uv_to_utf8(tmpbuf,nextmin);
2630	sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2631	t = uv_to_utf8(tmpbuf, 0x7fffffff);
2632	sv_catpvn(transv, "\377", 1);
2633	sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2634	t = (U8*)SvPVX(transv);
2635	tlen = SvCUR(transv);
2636	tend = t + tlen;
2637	}
2638	else if (!rlen && !del) {
2639	r = t; rlen = tlen; rend = tend;
2640	}
2641	if (!squash) {
2642	if (to_utf && from_utf) { /* only counting characters */
2643	if (t == r \|\| (tlen == rlen && memEQ(t, r, tlen)))
2644	o->op_private \|= OPpTRANS_IDENTICAL;
2645	}
2646	else { /* straight latin-1 translation */
2647	if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) &&
2648	rlen == 4 && memEQ(r, "\0\377\303\277", 4))
2649	o->op_private \|= OPpTRANS_IDENTICAL;
2650	}
2651	}
2652
2653	while (t < tend \|\| tfirst <= tlast) {
2654	/* see if we need more "t" chars */
2655	if (tfirst > tlast) {
2656	tfirst = (I32)utf8_to_uv(t, &ulen);
2657	t += ulen;
2658	if (t < tend && t == 0xff) { / illegal utf8 val indicates range */
2659	tlast = (I32)utf8_to_uv(++t, &ulen);
2660	t += ulen;
2661	}
2662	else
2663	tlast = tfirst;
2664	}
2665
2666	/* now see if we need more "r" chars */
2667	if (rfirst > rlast) {
2668	if (r < rend) {
2669	rfirst = (I32)utf8_to_uv(r, &ulen);
2670	r += ulen;
2671	if (r < rend && r == 0xff) { / illegal utf8 val indicates range */
2672	rlast = (I32)utf8_to_uv(++r, &ulen);
2673	r += ulen;
2674	}
2675	else
2676	rlast = rfirst;
2677	}
2678	else {
2679	if (!havefinal++)
2680	final = rlast;
2681	rfirst = rlast = 0xffffffff;
2682	}
2683	}
2684
2685	/* now see which range will peter our first, if either. */
2686	tdiff = tlast - tfirst;
2687	rdiff = rlast - rfirst;
2688
2689	if (tdiff <= rdiff)
2690	diff = tdiff;
2691	else
2692	diff = rdiff;
2693
2694	if (rfirst == 0xffffffff) {
2695	diff = tdiff; /* oops, pretend rdiff is infinite */
2696	if (diff > 0)
2697	Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2698	(long)tfirst, (long)tlast);
2699	else
2700	Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2701	}
2702	else {
2703	if (diff > 0)
2704	Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2705	(long)tfirst, (long)(tfirst + diff),
2706	(long)rfirst);
2707	else
2708	Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2709	(long)tfirst, (long)rfirst);
2710
2711	if (rfirst + diff > max)
2712	max = rfirst + diff;
2713	rfirst += diff + 1;
2714	if (!grows) {
2715	if (rfirst <= 0x80)
2716	;
2717	else if (rfirst <= 0x800)
2718	grows \|= (tfirst < 0x80);
2719	else if (rfirst <= 0x10000)
2720	grows \|= (tfirst < 0x800);
2721	else if (rfirst <= 0x200000)
2722	grows \|= (tfirst < 0x10000);
2723	else if (rfirst <= 0x4000000)
2724	grows \|= (tfirst < 0x200000);
2725	else if (rfirst <= 0x80000000)
2726	grows \|= (tfirst < 0x4000000);
2727	}
2728	}
2729	tfirst += diff + 1;
2730	}
2731
2732	none = ++max;
2733	if (del)
2734	del = ++max;
2735
2736	if (max > 0xffff)
2737	bits = 32;
2738	else if (max > 0xff)
2739	bits = 16;
2740	else
2741	bits = 8;
2742
2743	cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2744	SvREFCNT_dec(listsv);
2745	if (transv)
2746	SvREFCNT_dec(transv);
2747
2748	if (!del && havefinal)
2749	(void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2750	newSVuv((UV)final), 0);
2751
2752	if (grows && to_utf)
2753	o->op_private \|= OPpTRANS_GROWS;
2754
2755	op_free(expr);
2756	op_free(repl);
2757	return o;
2758	}
2759
2760	tbl = (short*)cPVOPo->op_pv;
2761	if (complement) {
2762	Zero(tbl, 256, short);
2763	for (i = 0; i < tlen; i++)
2764	tbl[t[i]] = -1;
2765	for (i = 0, j = 0; i < 256; i++) {
2766	if (!tbl[i]) {
2767	if (j >= rlen) {
2768	if (del)
2769	tbl[i] = -2;
2770	else if (rlen)
2771	tbl[i] = r[j-1];
2772	else
2773	tbl[i] = i;
2774	}
2775	else
2776	tbl[i] = r[j++];
2777	}
2778	}
2779	}
2780	else {
2781	if (!rlen && !del) {
2782	r = t; rlen = tlen;
2783	if (!squash)
2784	o->op_private \|= OPpTRANS_IDENTICAL;
2785	}
2786	for (i = 0; i < 256; i++)
2787	tbl[i] = -1;
2788	for (i = 0, j = 0; i < tlen; i++,j++) {
2789	if (j >= rlen) {
2790	if (del) {
2791	if (tbl[t[i]] == -1)
2792	tbl[t[i]] = -2;
2793	continue;
2794	}
2795	--j;
2796	}
2797	if (tbl[t[i]] == -1)
2798	tbl[t[i]] = r[j];
2799	}
2800	}
2801	op_free(expr);
2802	op_free(repl);
2803
2804	return o;
2805	}
2806
2807	OP *
2808	Perl_newPMOP(pTHX_ I32 type, I32 flags)
2809	{
2810	dTHR;
2811	PMOP *pmop;
2812
2813	NewOp(1101, pmop, 1, PMOP);
2814	pmop->op_type = type;
2815	pmop->op_ppaddr = PL_ppaddr[type];
2816	pmop->op_flags = flags;
2817	pmop->op_private = 0 \| (flags >> 8);
2818
2819	if (PL_hints & HINT_RE_TAINT)
2820	pmop->op_pmpermflags \|= PMf_RETAINT;
2821	if (PL_hints & HINT_LOCALE)
2822	pmop->op_pmpermflags \|= PMf_LOCALE;
2823	pmop->op_pmflags = pmop->op_pmpermflags;
2824
2825	/* link into pm list */
2826	if (type != OP_TRANS && PL_curstash) {
2827	pmop->op_pmnext = HvPMROOT(PL_curstash);
2828	HvPMROOT(PL_curstash) = pmop;
2829	}
2830
2831	return (OP*)pmop;
2832	}
2833
2834	OP *
2835	Perl_pmruntime(pTHX_ OP o, OP expr, OP *repl)
2836	{
2837	dTHR;
2838	PMOP *pm;
2839	LOGOP *rcop;
2840	I32 repl_has_vars = 0;
2841
2842	if (o->op_type == OP_TRANS)
2843	return pmtrans(o, expr, repl);
2844
2845	PL_hints \|= HINT_BLOCK_SCOPE;
2846	pm = (PMOP*)o;
2847
2848	if (expr->op_type == OP_CONST) {
2849	STRLEN plen;
2850	SV pat = ((SVOP)expr)->op_sv;
2851	char *p = SvPV(pat, plen);
2852	if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2853	sv_setpvn(pat, "\\s+", 3);
2854	p = SvPV(pat, plen);
2855	pm->op_pmflags \|= PMf_SKIPWHITE;
2856	}
2857	if ((PL_hints & HINT_UTF8) \|\| (SvUTF8(pat) && !(PL_hints & HINT_BYTE)))
2858	pm->op_pmdynflags \|= PMdf_UTF8;
2859	pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2860	if (strEQ("\\s+", pm->op_pmregexp->precomp))
2861	pm->op_pmflags \|= PMf_WHITE;
2862	op_free(expr);
2863	}
2864	else {
2865	if (PL_hints & HINT_UTF8)
2866	pm->op_pmdynflags \|= PMdf_UTF8;
2867	if (pm->op_pmflags & PMf_KEEP \|\| !(PL_hints & HINT_RE_EVAL))
2868	expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2869	? OP_REGCRESET
2870	: OP_REGCMAYBE),0,expr);
2871
2872	NewOp(1101, rcop, 1, LOGOP);
2873	rcop->op_type = OP_REGCOMP;
2874	rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2875	rcop->op_first = scalar(expr);
2876	rcop->op_flags \|= ((PL_hints & HINT_RE_EVAL)
2877	? (OPf_SPECIAL \| OPf_KIDS)
2878	: OPf_KIDS);
2879	rcop->op_private = 1;
2880	rcop->op_other = o;
2881
2882	/* establish postfix order */
2883	if (pm->op_pmflags & PMf_KEEP \|\| !(PL_hints & HINT_RE_EVAL)) {
2884	LINKLIST(expr);
2885	rcop->op_next = expr;
2886	((UNOP)expr)->op_first->op_next = (OP)rcop;
2887	}
2888	else {
2889	rcop->op_next = LINKLIST(expr);
2890	expr->op_next = (OP*)rcop;
2891	}
2892
2893	prepend_elem(o->op_type, scalar((OP*)rcop), o);
2894	}
2895
2896	if (repl) {
2897	OP *curop;
2898	if (pm->op_pmflags & PMf_EVAL) {
2899	curop = 0;
2900	if (CopLINE(PL_curcop) < PL_multi_end)
2901	CopLINE_set(PL_curcop, PL_multi_end);
2902	}
2903	#ifdef USE_THREADS
2904	else if (repl->op_type == OP_THREADSV
2905	&& strchr("&`'123456789+",
2906	PL_threadsv_names[repl->op_targ]))
2907	{
2908	curop = 0;
2909	}
2910	#endif /* USE_THREADS */
2911	else if (repl->op_type == OP_CONST)
2912	curop = repl;
2913	else {
2914	OP *lastop = 0;
2915	for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2916	if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2917	#ifdef USE_THREADS
2918	if (curop->op_type == OP_THREADSV) {
2919	repl_has_vars = 1;
2920	if (strchr("&`'123456789+", curop->op_private))
2921	break;
2922	}
2923	#else
2924	if (curop->op_type == OP_GV) {
2925	GV *gv = cGVOPx_gv(curop);
2926	repl_has_vars = 1;
2927	if (strchr("&`'123456789+", *GvENAME(gv)))
2928	break;
2929	}
2930	#endif /* USE_THREADS */
2931	else if (curop->op_type == OP_RV2CV)
2932	break;
2933	else if (curop->op_type == OP_RV2SV \|\|
2934	curop->op_type == OP_RV2AV \|\|
2935	curop->op_type == OP_RV2HV \|\|
2936	curop->op_type == OP_RV2GV) {
2937	if (lastop && lastop->op_type != OP_GV) /funny deref?/
2938	break;
2939	}
2940	else if (curop->op_type == OP_PADSV \|\|
2941	curop->op_type == OP_PADAV \|\|
2942	curop->op_type == OP_PADHV \|\|
2943	curop->op_type == OP_PADANY) {
2944	repl_has_vars = 1;
2945	}
2946	else if (curop->op_type == OP_PUSHRE)
2947	; /* Okay here, dangerous in newASSIGNOP */
2948	else
2949	break;
2950	}
2951	lastop = curop;
2952	}
2953	}
2954	if (curop == repl
2955	&& !(repl_has_vars
2956	&& (!pm->op_pmregexp
2957	\|\| pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
2958	pm->op_pmflags \|= PMf_CONST; /* const for long enough */
2959	pm->op_pmpermflags \|= PMf_CONST; /* const for long enough */
2960	prepend_elem(o->op_type, scalar(repl), o);
2961	}
2962	else {
2963	if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
2964	pm->op_pmflags \|= PMf_MAYBE_CONST;
2965	pm->op_pmpermflags \|= PMf_MAYBE_CONST;
2966	}
2967	NewOp(1101, rcop, 1, LOGOP);
2968	rcop->op_type = OP_SUBSTCONT;
2969	rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2970	rcop->op_first = scalar(repl);
2971	rcop->op_flags \|= OPf_KIDS;
2972	rcop->op_private = 1;
2973	rcop->op_other = o;
2974
2975	/* establish postfix order */
2976	rcop->op_next = LINKLIST(repl);
2977	repl->op_next = (OP*)rcop;
2978
2979	pm->op_pmreplroot = scalar((OP*)rcop);
2980	pm->op_pmreplstart = LINKLIST(rcop);
2981	rcop->op_next = 0;
2982	}
2983	}
2984
2985	return (OP*)pm;
2986	}
2987
2988	OP *
2989	Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2990	{
2991	SVOP *svop;
2992	NewOp(1101, svop, 1, SVOP);
2993	svop->op_type = type;
2994	svop->op_ppaddr = PL_ppaddr[type];
2995	svop->op_sv = sv;
2996	svop->op_next = (OP*)svop;
2997	svop->op_flags = flags;
2998	if (PL_opargs[type] & OA_RETSCALAR)
2999	scalar((OP*)svop);
3000	if (PL_opargs[type] & OA_TARGET)
3001	svop->op_targ = pad_alloc(type, SVs_PADTMP);
3002	return CHECKOP(type, svop);
3003	}
3004
3005	OP *
3006	Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3007	{
3008	PADOP *padop;
3009	NewOp(1101, padop, 1, PADOP);
3010	padop->op_type = type;
3011	padop->op_ppaddr = PL_ppaddr[type];
3012	padop->op_padix = pad_alloc(type, SVs_PADTMP);
3013	SvREFCNT_dec(PL_curpad[padop->op_padix]);
3014	PL_curpad[padop->op_padix] = sv;
3015	SvPADTMP_on(sv);
3016	padop->op_next = (OP*)padop;
3017	padop->op_flags = flags;
3018	if (PL_opargs[type] & OA_RETSCALAR)
3019	scalar((OP*)padop);
3020	if (PL_opargs[type] & OA_TARGET)
3021	padop->op_targ = pad_alloc(type, SVs_PADTMP);
3022	return CHECKOP(type, padop);
3023	}
3024
3025	OP *
3026	Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3027	{
3028	dTHR;
3029	#ifdef USE_ITHREADS
3030	GvIN_PAD_on(gv);
3031	return newPADOP(type, flags, SvREFCNT_inc(gv));
3032	#else
3033	return newSVOP(type, flags, SvREFCNT_inc(gv));
3034	#endif
3035	}
3036
3037	OP *
3038	Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3039	{
3040	PVOP *pvop;
3041	NewOp(1101, pvop, 1, PVOP);
3042	pvop->op_type = type;
3043	pvop->op_ppaddr = PL_ppaddr[type];
3044	pvop->op_pv = pv;
3045	pvop->op_next = (OP*)pvop;
3046	pvop->op_flags = flags;
3047	if (PL_opargs[type] & OA_RETSCALAR)
3048	scalar((OP*)pvop);
3049	if (PL_opargs[type] & OA_TARGET)
3050	pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3051	return CHECKOP(type, pvop);
3052	}
3053
3054	void
3055	Perl_package(pTHX_ OP *o)
3056	{
3057	dTHR;
3058	SV *sv;
3059
3060	save_hptr(&PL_curstash);
3061	save_item(PL_curstname);
3062	if (o) {
3063	STRLEN len;
3064	char *name;
3065	sv = cSVOPo->op_sv;
3066	name = SvPV(sv, len);
3067	PL_curstash = gv_stashpvn(name,len,TRUE);
3068	sv_setpvn(PL_curstname, name, len);
3069	op_free(o);
3070	}
3071	else {
3072	sv_setpv(PL_curstname,"<none>");
3073	PL_curstash = Nullhv;
3074	}
3075	PL_hints \|= HINT_BLOCK_SCOPE;
3076	PL_copline = NOLINE;
3077	PL_expect = XSTATE;
3078	}
3079
3080	void
3081	Perl_utilize(pTHX_ int aver, I32 floor, OP version, OP id, OP *arg)
3082	{
3083	OP *pack;
3084	OP *rqop;
3085	OP *imop;
3086	OP *veop;
3087	GV *gv;
3088
3089	if (id->op_type != OP_CONST)
3090	Perl_croak(aTHX_ "Module name must be constant");
3091
3092	veop = Nullop;
3093
3094	if (version != Nullop) {
3095	SV vesv = ((SVOP)version)->op_sv;
3096
3097	if (arg == Nullop && !SvNIOKp(vesv)) {
3098	arg = version;
3099	}
3100	else {
3101	OP *pack;
3102	SV *meth;
3103
3104	if (version->op_type != OP_CONST \|\| !SvNIOKp(vesv))
3105	Perl_croak(aTHX_ "Version number must be constant number");
3106
3107	/* Make copy of id so we don't free it twice */
3108	pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3109
3110	/* Fake up a method call to VERSION */
3111	meth = newSVpvn("VERSION",7);
3112	sv_upgrade(meth, SVt_PVIV);
3113	(void)SvIOK_on(meth);
3114	PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3115	veop = convert(OP_ENTERSUB, OPf_STACKED\|OPf_SPECIAL,
3116	append_elem(OP_LIST,
3117	prepend_elem(OP_LIST, pack, list(version)),
3118	newSVOP(OP_METHOD_NAMED, 0, meth)));
3119	}
3120	}
3121
3122	/* Fake up an import/unimport */
3123	if (arg && arg->op_type == OP_STUB)
3124	imop = arg; /* no import on explicit () */
3125	else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3126	imop = Nullop; /* use 5.0; */
3127	}
3128	else {
3129	SV *meth;
3130
3131	/* Make copy of id so we don't free it twice */
3132	pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3133
3134	/* Fake up a method call to import/unimport */
3135	meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3136	sv_upgrade(meth, SVt_PVIV);
3137	(void)SvIOK_on(meth);
3138	PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3139	imop = convert(OP_ENTERSUB, OPf_STACKED\|OPf_SPECIAL,
3140	append_elem(OP_LIST,
3141	prepend_elem(OP_LIST, pack, list(arg)),
3142	newSVOP(OP_METHOD_NAMED, 0, meth)));
3143	}
3144
3145	/* Fake up a require, handle override, if any */
3146	gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3147	if (!(gv && GvIMPORTED_CV(gv)))
3148	gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3149
3150	if (gv && GvIMPORTED_CV(gv)) {
3151	rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3152	append_elem(OP_LIST, id,
3153	scalar(newUNOP(OP_RV2CV, 0,
3154	newGVOP(OP_GV, 0,
3155	gv))))));
3156	}
3157	else {
3158	rqop = newUNOP(OP_REQUIRE, 0, id);
3159	}
3160
3161	/* Fake up the BEGIN {}, which does its thing immediately. */
3162	newATTRSUB(floor,
3163	newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3164	Nullop,
3165	Nullop,
3166	append_elem(OP_LINESEQ,
3167	append_elem(OP_LINESEQ,
3168	newSTATEOP(0, Nullch, rqop),
3169	newSTATEOP(0, Nullch, veop)),
3170	newSTATEOP(0, Nullch, imop) ));
3171
3172	PL_hints \|= HINT_BLOCK_SCOPE;
3173	PL_copline = NOLINE;
3174	PL_expect = XSTATE;
3175	}
3176
3177	void
3178	Perl_load_module(pTHX_ U32 flags, SV name, SV ver, ...)
3179	{
3180	va_list args;
3181	va_start(args, ver);
3182	vload_module(flags, name, ver, &args);
3183	va_end(args);
3184	}
3185
3186	#ifdef PERL_IMPLICIT_CONTEXT
3187	void
3188	Perl_load_module_nocontext(U32 flags, SV name, SV ver, ...)
3189	{
3190	dTHX;
3191	va_list args;
3192	va_start(args, ver);
3193	vload_module(flags, name, ver, &args);
3194	va_end(args);
3195	}
3196	#endif
3197
3198	void
3199	Perl_vload_module(pTHX_ U32 flags, SV name, SV ver, va_list *args)
3200	{
3201	OP modname, veop, *imop;
3202
3203	modname = newSVOP(OP_CONST, 0, name);
3204	modname->op_private \|= OPpCONST_BARE;
3205	if (ver) {
3206	veop = newSVOP(OP_CONST, 0, ver);
3207	}
3208	else
3209	veop = Nullop;
3210	if (flags & PERL_LOADMOD_NOIMPORT) {
3211	imop = sawparens(newNULLLIST());
3212	}
3213	else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3214	imop = va_arg(args, OP);
3215	}
3216	else {
3217	SV *sv;
3218	imop = Nullop;
3219	sv = va_arg(args, SV);
3220	while (sv) {
3221	imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3222	sv = va_arg(args, SV);
3223	}
3224	}
3225	utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3226	veop, modname, imop);
3227	}
3228
3229	OP *
3230	Perl_dofile(pTHX_ OP *term)
3231	{
3232	OP *doop;
3233	GV *gv;
3234
3235	gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3236	if (!(gv && GvIMPORTED_CV(gv)))
3237	gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3238
3239	if (gv && GvIMPORTED_CV(gv)) {
3240	doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3241	append_elem(OP_LIST, term,
3242	scalar(newUNOP(OP_RV2CV, 0,
3243	newGVOP(OP_GV, 0,
3244	gv))))));
3245	}
3246	else {
3247	doop = newUNOP(OP_DOFILE, 0, scalar(term));
3248	}
3249	return doop;
3250	}
3251
3252	OP *
3253	Perl_newSLICEOP(pTHX_ I32 flags, OP subscript, OP listval)
3254	{
3255	return newBINOP(OP_LSLICE, flags,
3256	list(force_list(subscript)),
3257	list(force_list(listval)) );
3258	}
3259
3260	STATIC I32
3261	S_list_assignment(pTHX_ register OP *o)
3262	{
3263	if (!o)
3264	return TRUE;
3265
3266	if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3267	o = cUNOPo->op_first;
3268
3269	if (o->op_type == OP_COND_EXPR) {
3270	I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3271	I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3272
3273	if (t && f)
3274	return TRUE;
3275	if (t \|\| f)
3276	yyerror("Assignment to both a list and a scalar");
3277	return FALSE;
3278	}
3279
3280	if (o->op_type == OP_LIST \|\| o->op_flags & OPf_PARENS \|\|
3281	o->op_type == OP_RV2AV \|\| o->op_type == OP_RV2HV \|\|
3282	o->op_type == OP_ASLICE \|\| o->op_type == OP_HSLICE)
3283	return TRUE;
3284
3285	if (o->op_type == OP_PADAV \|\| o->op_type == OP_PADHV)
3286	return TRUE;
3287
3288	if (o->op_type == OP_RV2SV)
3289	return FALSE;
3290
3291	return FALSE;
3292	}
3293
3294	OP *
3295	Perl_newASSIGNOP(pTHX_ I32 flags, OP left, I32 optype, OP right)
3296	{
3297	OP *o;
3298
3299	if (optype) {
3300	if (optype == OP_ANDASSIGN \|\| optype == OP_ORASSIGN) {
3301	return newLOGOP(optype, 0,
3302	mod(scalar(left), optype),
3303	newUNOP(OP_SASSIGN, 0, scalar(right)));
3304	}
3305	else {
3306	return newBINOP(optype, OPf_STACKED,
3307	mod(scalar(left), optype), scalar(right));
3308	}
3309	}
3310
3311	if (list_assignment(left)) {
3312	dTHR;
3313	OP *curop;
3314
3315	PL_modcount = 0;
3316	PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3317	left = mod(left, OP_AASSIGN);
3318	if (PL_eval_start)
3319	PL_eval_start = 0;
3320	else {
3321	op_free(left);
3322	op_free(right);
3323	return Nullop;
3324	}
3325	curop = list(force_list(left));
3326	o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3327	o->op_private = 0 \| (flags >> 8);
3328	for (curop = ((LISTOP*)curop)->op_first;
3329	curop; curop = curop->op_sibling)
3330	{
3331	if (curop->op_type == OP_RV2HV &&
3332	((UNOP*)curop)->op_first->op_type != OP_GV) {
3333	o->op_private \|= OPpASSIGN_HASH;
3334	break;
3335	}
3336	}
3337	if (!(left->op_private & OPpLVAL_INTRO)) {
3338	OP *lastop = o;
3339	PL_generation++;
3340	for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3341	if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3342	if (curop->op_type == OP_GV) {
3343	GV *gv = cGVOPx_gv(curop);
3344	if (gv == PL_defgv \|\| SvCUR(gv) == PL_generation)
3345	break;
3346	SvCUR(gv) = PL_generation;
3347	}
3348	else if (curop->op_type == OP_PADSV \|\|
3349	curop->op_type == OP_PADAV \|\|
3350	curop->op_type == OP_PADHV \|\|
3351	curop->op_type == OP_PADANY) {
3352	SV **svp = AvARRAY(PL_comppad_name);
3353	SV *sv = svp[curop->op_targ];
3354	if (SvCUR(sv) == PL_generation)
3355	break;
3356	SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
3357	}
3358	else if (curop->op_type == OP_RV2CV)
3359	break;
3360	else if (curop->op_type == OP_RV2SV \|\|
3361	curop->op_type == OP_RV2AV \|\|
3362	curop->op_type == OP_RV2HV \|\|
3363	curop->op_type == OP_RV2GV) {
3364	if (lastop->op_type != OP_GV) /* funny deref? */
3365	break;
3366	}
3367	else if (curop->op_type == OP_PUSHRE) {
3368	if (((PMOP*)curop)->op_pmreplroot) {
3369	GV gv = (GV)((PMOP*)curop)->op_pmreplroot;
3370	if (gv == PL_defgv \|\| SvCUR(gv) == PL_generation)
3371	break;
3372	SvCUR(gv) = PL_generation;
3373	}
3374	}
3375	else
3376	break;
3377	}
3378	lastop = curop;
3379	}
3380	if (curop != o)
3381	o->op_private \|= OPpASSIGN_COMMON;
3382	}
3383	if (right && right->op_type == OP_SPLIT) {
3384	OP* tmpop;
3385	if ((tmpop = ((LISTOP*)right)->op_first) &&
3386	tmpop->op_type == OP_PUSHRE)
3387	{
3388	PMOP pm = (PMOP)tmpop;
3389	if (left->op_type == OP_RV2AV &&
3390	!(left->op_private & OPpLVAL_INTRO) &&
3391	!(o->op_private & OPpASSIGN_COMMON) )
3392	{
3393	tmpop = ((UNOP*)left)->op_first;
3394	if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3395	#ifdef USE_ITHREADS
3396	pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3397	cPADOPx(tmpop)->op_padix = 0; /* steal it */
3398	#else
3399	pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3400	cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3401	#endif
3402	pm->op_pmflags \|= PMf_ONCE;
3403	tmpop = cUNOPo->op_first; /* to list (nulled) */
3404	tmpop = ((UNOP)tmpop)->op_first; / to pushmark */
3405	tmpop->op_sibling = Nullop; /* don't free split */
3406	right->op_next = tmpop->op_next; /* fix starting loc */
3407	op_free(o); /* blow off assign */
3408	right->op_flags &= ~OPf_WANT;
3409	/* "I don't know and I don't care." */
3410	return right;
3411	}
3412	}
3413	else {
3414	if (PL_modcount < 10000 &&
3415	((LISTOP*)right)->op_last->op_type == OP_CONST)
3416	{
3417	SV sv = ((SVOP)((LISTOP*)right)->op_last)->op_sv;
3418	if (SvIVX(sv) == 0)
3419	sv_setiv(sv, PL_modcount+1);
3420	}
3421	}
3422	}
3423	}
3424	return o;
3425	}
3426	if (!right)
3427	right = newOP(OP_UNDEF, 0);
3428	if (right->op_type == OP_READLINE) {
3429	right->op_flags \|= OPf_STACKED;
3430	return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3431	}
3432	else {
3433	PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3434	o = newBINOP(OP_SASSIGN, flags,
3435	scalar(right), mod(scalar(left), OP_SASSIGN) );
3436	if (PL_eval_start)
3437	PL_eval_start = 0;
3438	else {
3439	op_free(o);
3440	return Nullop;
3441	}
3442	}
3443	return o;
3444	}
3445
3446	OP *
3447	Perl_newSTATEOP(pTHX_ I32 flags, char label, OP o)
3448	{
3449	dTHR;
3450	U32 seq = intro_my();
3451	register COP *cop;
3452
3453	NewOp(1101, cop, 1, COP);
3454	if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3455	cop->op_type = OP_DBSTATE;
3456	cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3457	}
3458	else {
3459	cop->op_type = OP_NEXTSTATE;
3460	cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3461	}
3462	cop->op_flags = flags;
3463	cop->op_private = (PL_hints & HINT_BYTE);
3464	#ifdef NATIVE_HINTS
3465	cop->op_private \|= NATIVE_HINTS;
3466	#endif
3467	PL_compiling.op_private = cop->op_private;
3468	cop->op_next = (OP*)cop;
3469
3470	if (label) {
3471	cop->cop_label = label;
3472	PL_hints \|= HINT_BLOCK_SCOPE;
3473	}
3474	cop->cop_seq = seq;
3475	cop->cop_arybase = PL_curcop->cop_arybase;
3476	if (specialWARN(PL_curcop->cop_warnings))
3477	cop->cop_warnings = PL_curcop->cop_warnings ;
3478	else
3479	cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3480
3481
3482	if (PL_copline == NOLINE)
3483	CopLINE_set(cop, CopLINE(PL_curcop));
3484	else {
3485	CopLINE_set(cop, PL_copline);
3486	PL_copline = NOLINE;
3487	}
3488	#ifdef USE_ITHREADS
3489	CopFILE_set(cop, CopFILE(PL_curcop)); /* XXXXX share in a pvtable? */
3490	#else
3491	CopFILEGV_set(cop, (GV*)SvREFCNT_inc(CopFILEGV(PL_curcop)));
3492	#endif
3493	CopSTASH_set(cop, PL_curstash);
3494
3495	if (PERLDB_LINE && PL_curstash != PL_debstash) {
3496	SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3497	if (svp && svp != &PL_sv_undef && !SvIOK(svp)) {
3498	(void)SvIOK_on(*svp);
3499	SvIVX(*svp) = PTR2IV(cop);
3500	}
3501	}
3502
3503	return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3504	}
3505
3506	/* "Introduce" my variables to visible status. */
3507	U32
3508	Perl_intro_my(pTHX)
3509	{
3510	SV **svp;
3511	SV *sv;
3512	I32 i;
3513
3514	if (! PL_min_intro_pending)
3515	return PL_cop_seqmax;
3516
3517	svp = AvARRAY(PL_comppad_name);
3518	for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3519	if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3520	SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */
3521	SvNVX(sv) = (NV)PL_cop_seqmax;
3522	}
3523	}
3524	PL_min_intro_pending = 0;
3525	PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */
3526	return PL_cop_seqmax++;
3527	}
3528
3529	OP *
3530	Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP first, OP other)
3531	{
3532	return new_logop(type, flags, &first, &other);
3533	}
3534
3535	STATIC OP *
3536	S_new_logop(pTHX_ I32 type, I32 flags, OP firstp, OP otherp)
3537	{
3538	dTHR;
3539	LOGOP *logop;
3540	OP *o;
3541	OP first = firstp;
3542	OP other = otherp;
3543
3544	if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3545	return newBINOP(type, flags, scalar(first), scalar(other));
3546
3547	scalarboolean(first);
3548	/* optimize "!a && b" to "a \|\| b", and "!a \|\| b" to "a && b" */
3549	if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3550	if (type == OP_AND \|\| type == OP_OR) {
3551	if (type == OP_AND)
3552	type = OP_OR;
3553	else
3554	type = OP_AND;
3555	o = first;
3556	first = *firstp = cUNOPo->op_first;
3557	if (o->op_next)
3558	first->op_next = o->op_next;
3559	cUNOPo->op_first = Nullop;
3560	op_free(o);
3561	}
3562	}
3563	if (first->op_type == OP_CONST) {
3564	if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3565	Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3566	if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3567	op_free(first);
3568	*firstp = Nullop;
3569	return other;
3570	}
3571	else {
3572	op_free(other);
3573	*otherp = Nullop;
3574	return first;
3575	}
3576	}
3577	else if (first->op_type == OP_WANTARRAY) {
3578	if (type == OP_AND)
3579	list(other);
3580	else
3581	scalar(other);
3582	}
3583	else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3584	OP k1 = ((UNOP)first)->op_first;
3585	OP *k2 = k1->op_sibling;
3586	OPCODE warnop = 0;
3587	switch (first->op_type)
3588	{
3589	case OP_NULL:
3590	if (k2 && k2->op_type == OP_READLINE
3591	&& (k2->op_flags & OPf_STACKED)
3592	&& ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3593	{
3594	warnop = k2->op_type;
3595	}
3596	break;
3597
3598	case OP_SASSIGN:
3599	if (k1->op_type == OP_READDIR
3600	\|\| k1->op_type == OP_GLOB
3601	\|\| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3602	\|\| k1->op_type == OP_EACH)
3603	{
3604	warnop = ((k1->op_type == OP_NULL)
3605	? k1->op_targ : k1->op_type);
3606	}
3607	break;
3608	}
3609	if (warnop) {
3610	line_t oldline = CopLINE(PL_curcop);
3611	CopLINE_set(PL_curcop, PL_copline);
3612	Perl_warner(aTHX_ WARN_MISC,
3613	"Value of %s%s can be \"0\"; test with defined()",
3614	PL_op_desc[warnop],
3615	((warnop == OP_READLINE \|\| warnop == OP_GLOB)
3616	? " construct" : "() operator"));
3617	CopLINE_set(PL_curcop, oldline);
3618	}
3619	}
3620
3621	if (!other)
3622	return first;
3623
3624	if (type == OP_ANDASSIGN \|\| type == OP_ORASSIGN)
3625	other->op_private \|= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3626
3627	NewOp(1101, logop, 1, LOGOP);
3628
3629	logop->op_type = type;
3630	logop->op_ppaddr = PL_ppaddr[type];
3631	logop->op_first = first;
3632	logop->op_flags = flags \| OPf_KIDS;
3633	logop->op_other = LINKLIST(other);
3634	logop->op_private = 1 \| (flags >> 8);
3635
3636	/* establish postfix order */
3637	logop->op_next = LINKLIST(first);
3638	first->op_next = (OP*)logop;
3639	first->op_sibling = other;
3640
3641	o = newUNOP(OP_NULL, 0, (OP*)logop);
3642	other->op_next = o;
3643
3644	return o;
3645	}
3646
3647	OP *
3648	Perl_newCONDOP(pTHX_ I32 flags, OP first, OP trueop, OP *falseop)
3649	{
3650	dTHR;
3651	LOGOP *logop;
3652	OP *start;
3653	OP *o;
3654
3655	if (!falseop)
3656	return newLOGOP(OP_AND, 0, first, trueop);
3657	if (!trueop)
3658	return newLOGOP(OP_OR, 0, first, falseop);
3659
3660	scalarboolean(first);
3661	if (first->op_type == OP_CONST) {
3662	if (SvTRUE(((SVOP*)first)->op_sv)) {
3663	op_free(first);
3664	op_free(falseop);
3665	return trueop;
3666	}
3667	else {
3668	op_free(first);
3669	op_free(trueop);
3670	return falseop;
3671	}
3672	}
3673	else if (first->op_type == OP_WANTARRAY) {
3674	list(trueop);
3675	scalar(falseop);
3676	}
3677	NewOp(1101, logop, 1, LOGOP);
3678	logop->op_type = OP_COND_EXPR;
3679	logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3680	logop->op_first = first;
3681	logop->op_flags = flags \| OPf_KIDS;
3682	logop->op_private = 1 \| (flags >> 8);
3683	logop->op_other = LINKLIST(trueop);
3684	logop->op_next = LINKLIST(falseop);
3685
3686
3687	/* establish postfix order */
3688	start = LINKLIST(first);
3689	first->op_next = (OP*)logop;
3690
3691	first->op_sibling = trueop;
3692	trueop->op_sibling = falseop;
3693	o = newUNOP(OP_NULL, 0, (OP*)logop);
3694
3695	trueop->op_next = falseop->op_next = o;
3696
3697	o->op_next = start;
3698	return o;
3699	}
3700
3701	OP *
3702	Perl_newRANGE(pTHX_ I32 flags, OP left, OP right)
3703	{
3704	dTHR;
3705	LOGOP *range;
3706	OP *flip;
3707	OP *flop;
3708	OP *leftstart;
3709	OP *o;
3710
3711	NewOp(1101, range, 1, LOGOP);
3712
3713	range->op_type = OP_RANGE;
3714	range->op_ppaddr = PL_ppaddr[OP_RANGE];
3715	range->op_first = left;
3716	range->op_flags = OPf_KIDS;
3717	leftstart = LINKLIST(left);
3718	range->op_other = LINKLIST(right);
3719	range->op_private = 1 \| (flags >> 8);
3720
3721	left->op_sibling = right;
3722
3723	range->op_next = (OP*)range;
3724	flip = newUNOP(OP_FLIP, flags, (OP*)range);
3725	flop = newUNOP(OP_FLOP, 0, flip);
3726	o = newUNOP(OP_NULL, 0, flop);
3727	linklist(flop);
3728	range->op_next = leftstart;
3729
3730	left->op_next = flip;
3731	right->op_next = flop;
3732
3733	range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3734	sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3735	flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3736	sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3737
3738	flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3739	flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3740
3741	flip->op_next = o;
3742	if (!flip->op_private \|\| !flop->op_private)
3743	linklist(o); /* blow off optimizer unless constant */
3744
3745	return o;
3746	}
3747
3748	OP *
3749	Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP expr, OP block)
3750	{
3751	dTHR;
3752	OP* listop;
3753	OP* o;
3754	int once = block && block->op_flags & OPf_SPECIAL &&
3755	(block->op_type == OP_ENTERSUB \|\| block->op_type == OP_NULL);
3756
3757	if (expr) {
3758	if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3759	return block; /* do {} while 0 does once */
3760	if (expr->op_type == OP_READLINE \|\| expr->op_type == OP_GLOB
3761	\|\| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3762	expr = newUNOP(OP_DEFINED, 0,
3763	newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3764	} else if (expr->op_flags & OPf_KIDS) {
3765	OP k1 = ((UNOP)expr)->op_first;
3766	OP *k2 = (k1) ? k1->op_sibling : NULL;
3767	switch (expr->op_type) {
3768	case OP_NULL:
3769	if (k2 && k2->op_type == OP_READLINE
3770	&& (k2->op_flags & OPf_STACKED)
3771	&& ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3772	expr = newUNOP(OP_DEFINED, 0, expr);
3773	break;
3774
3775	case OP_SASSIGN:
3776	if (k1->op_type == OP_READDIR
3777	\|\| k1->op_type == OP_GLOB
3778	\|\| (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3779	\|\| k1->op_type == OP_EACH)
3780	expr = newUNOP(OP_DEFINED, 0, expr);
3781	break;
3782	}
3783	}
3784	}
3785
3786	listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3787	o = new_logop(OP_AND, 0, &expr, &listop);
3788
3789	if (listop)
3790	((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3791
3792	if (once && o != listop)
3793	o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3794
3795	if (o == listop)
3796	o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3797
3798	o->op_flags \|= flags;
3799	o = scope(o);
3800	o->op_flags \|= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3801	return o;
3802	}
3803
3804	OP *
3805	Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP loop, I32 whileline, OP expr, OP block, OP cont)
3806	{
3807	dTHR;
3808	OP *redo;
3809	OP *next = 0;
3810	OP *listop;
3811	OP *o;
3812	OP *condop;
3813	U8 loopflags = 0;
3814
3815	if (expr && (expr->op_type == OP_READLINE \|\| expr->op_type == OP_GLOB
3816	\|\| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3817	expr = newUNOP(OP_DEFINED, 0,
3818	newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3819	} else if (expr && (expr->op_flags & OPf_KIDS)) {
3820	OP k1 = ((UNOP)expr)->op_first;
3821	OP *k2 = (k1) ? k1->op_sibling : NULL;
3822	switch (expr->op_type) {
3823	case OP_NULL:
3824	if (k2 && k2->op_type == OP_READLINE
3825	&& (k2->op_flags & OPf_STACKED)
3826	&& ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3827	expr = newUNOP(OP_DEFINED, 0, expr);
3828	break;
3829
3830	case OP_SASSIGN:
3831	if (k1->op_type == OP_READDIR
3832	\|\| k1->op_type == OP_GLOB
3833	\|\| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3834	\|\| k1->op_type == OP_EACH)
3835	expr = newUNOP(OP_DEFINED, 0, expr);
3836	break;
3837	}
3838	}
3839
3840	if (!block)
3841	block = newOP(OP_NULL, 0);
3842	else if (cont) {
3843	block = scope(block);
3844	}
3845
3846	if (cont) {
3847	next = LINKLIST(cont);
3848	loopflags \|= OPpLOOP_CONTINUE;
3849	}
3850	if (expr) {
3851	cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
3852	if ((line_t)whileline != NOLINE) {
3853	PL_copline = whileline;
3854	cont = append_elem(OP_LINESEQ, cont,
3855	newSTATEOP(0, Nullch, Nullop));
3856	}
3857	}
3858
3859	listop = append_list(OP_LINESEQ, (LISTOP)block, (LISTOP)cont);
3860	redo = LINKLIST(listop);
3861
3862	if (expr) {
3863	PL_copline = whileline;
3864	scalar(listop);
3865	o = new_logop(OP_AND, 0, &expr, &listop);
3866	if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3867	op_free(expr); /* oops, it's a while (0) */
3868	op_free((OP*)loop);
3869	return Nullop; /* listop already freed by new_logop */
3870	}
3871	if (listop)
3872	((LISTOP*)listop)->op_last->op_next = condop =
3873	(o == listop ? redo : LINKLIST(o));
3874	if (!next)
3875	next = condop;
3876	}
3877	else
3878	o = listop;
3879
3880	if (!loop) {
3881	NewOp(1101,loop,1,LOOP);
3882	loop->op_type = OP_ENTERLOOP;
3883	loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3884	loop->op_private = 0;
3885	loop->op_next = (OP*)loop;
3886	}
3887
3888	o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3889
3890	loop->op_redoop = redo;
3891	loop->op_lastop = o;
3892	o->op_private \|= loopflags;
3893
3894	if (next)
3895	loop->op_nextop = next;
3896	else
3897	loop->op_nextop = o;
3898
3899	o->op_flags \|= flags;
3900	o->op_private \|= (flags >> 8);
3901	return o;
3902	}
3903
3904	OP *
3905	Perl_newFOROP(pTHX_ I32 flags,char label,line_t forline,OP sv,OP expr,OP block,OP *cont)
3906	{
3907	LOOP *loop;
3908	OP *wop;
3909	int padoff = 0;
3910	I32 iterflags = 0;
3911
3912	if (sv) {
3913	if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3914	sv->op_type = OP_RV2GV;
3915	sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3916	}
3917	else if (sv->op_type == OP_PADSV) { /* private variable */
3918	padoff = sv->op_targ;
3919	sv->op_targ = 0;
3920	op_free(sv);
3921	sv = Nullop;
3922	}
3923	else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3924	padoff = sv->op_targ;
3925	sv->op_targ = 0;
3926	iterflags \|= OPf_SPECIAL;
3927	op_free(sv);
3928	sv = Nullop;
3929	}
3930	else
3931	Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3932	}
3933	else {
3934	#ifdef USE_THREADS
3935	padoff = find_threadsv("_");
3936	iterflags \|= OPf_SPECIAL;
3937	#else
3938	sv = newGVOP(OP_GV, 0, PL_defgv);
3939	#endif
3940	}
3941	if (expr->op_type == OP_RV2AV \|\| expr->op_type == OP_PADAV) {
3942	expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3943	iterflags \|= OPf_STACKED;
3944	}
3945	else if (expr->op_type == OP_NULL &&
3946	(expr->op_flags & OPf_KIDS) &&
3947	((BINOP*)expr)->op_first->op_type == OP_FLOP)
3948	{
3949	/* Basically turn for($x..$y) into the same as for($x,$y), but we
3950	* set the STACKED flag to indicate that these values are to be
3951	* treated as min/max values by 'pp_iterinit'.
3952	*/
3953	UNOP* flip = (UNOP)((UNOP)((BINOP*)expr)->op_first)->op_first;
3954	LOGOP* range = (LOGOP*) flip->op_first;
3955	OP* left = range->op_first;
3956	OP* right = left->op_sibling;
3957	LISTOP* listop;
3958
3959	range->op_flags &= ~OPf_KIDS;
3960	range->op_first = Nullop;
3961
3962	listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3963	listop->op_first->op_next = range->op_next;
3964	left->op_next = range->op_other;
3965	right->op_next = (OP*)listop;
3966	listop->op_next = listop->op_first;
3967
3968	op_free(expr);
3969	expr = (OP*)(listop);
3970	null(expr);
3971	iterflags \|= OPf_STACKED;
3972	}
3973	else {
3974	expr = mod(force_list(expr), OP_GREPSTART);
3975	}
3976
3977
3978	loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3979	append_elem(OP_LIST, expr, scalar(sv))));
3980	assert(!loop->op_next);
3981	#ifdef PL_OP_SLAB_ALLOC
3982	{
3983	LOOP *tmp;
3984	NewOp(1234,tmp,1,LOOP);
3985	Copy(loop,tmp,1,LOOP);
3986	loop = tmp;
3987	}
3988	#else
3989	Renew(loop, 1, LOOP);
3990	#endif
3991	loop->op_targ = padoff;
3992	wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3993	PL_copline = forline;
3994	return newSTATEOP(0, label, wop);
3995	}
3996
3997	OP*
3998	Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3999	{
4000	dTHR;
4001	OP *o;
4002	STRLEN n_a;
4003
4004	if (type != OP_GOTO \|\| label->op_type == OP_CONST) {
4005	/* "last()" means "last" */
4006	if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4007	o = newOP(type, OPf_SPECIAL);
4008	else {
4009	o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4010	? SvPVx(((SVOP*)label)->op_sv, n_a)
4011	: ""));
4012	}
4013	op_free(label);
4014	}
4015	else {
4016	if (label->op_type == OP_ENTERSUB)
4017	label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4018	o = newUNOP(type, OPf_STACKED, label);
4019	}
4020	PL_hints \|= HINT_BLOCK_SCOPE;
4021	return o;
4022	}
4023
4024	void
4025	Perl_cv_undef(pTHX_ CV *cv)
4026	{
4027	dTHR;
4028	#ifdef USE_THREADS
4029	if (CvMUTEXP(cv)) {
4030	MUTEX_DESTROY(CvMUTEXP(cv));
4031	Safefree(CvMUTEXP(cv));
4032	CvMUTEXP(cv) = 0;
4033	}
4034	#endif /* USE_THREADS */
4035
4036	if (!CvXSUB(cv) && CvROOT(cv)) {
4037	#ifdef USE_THREADS
4038	if (CvDEPTH(cv) \|\| (CvOWNER(cv) && CvOWNER(cv) != thr))
4039	Perl_croak(aTHX_ "Can't undef active subroutine");
4040	#else
4041	if (CvDEPTH(cv))
4042	Perl_croak(aTHX_ "Can't undef active subroutine");
4043	#endif /* USE_THREADS */
4044	ENTER;
4045
4046	SAVEVPTR(PL_curpad);
4047	PL_curpad = 0;
4048
4049	if (!CvCLONED(cv))
4050	op_free(CvROOT(cv));
4051	CvROOT(cv) = Nullop;
4052	LEAVE;
4053	}
4054	SvPOK_off((SV)cv); / forget prototype */
4055	CvFLAGS(cv) = 0;
4056	SvREFCNT_dec(CvGV(cv));
4057	CvGV(cv) = Nullgv;
4058	SvREFCNT_dec(CvOUTSIDE(cv));
4059	CvOUTSIDE(cv) = Nullcv;
4060	if (CvPADLIST(cv)) {
4061	/* may be during global destruction */
4062	if (SvREFCNT(CvPADLIST(cv))) {
4063	I32 i = AvFILLp(CvPADLIST(cv));
4064	while (i >= 0) {
4065	SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4066	SV* sv = svp ? *svp : Nullsv;
4067	if (!sv)
4068	continue;
4069	if (sv == (SV*)PL_comppad_name)
4070	PL_comppad_name = Nullav;
4071	else if (sv == (SV*)PL_comppad) {
4072	PL_comppad = Nullav;
4073	PL_curpad = Null(SV**);
4074	}
4075	SvREFCNT_dec(sv);
4076	}
4077	SvREFCNT_dec((SV*)CvPADLIST(cv));
4078	}
4079	CvPADLIST(cv) = Nullav;
4080	}
4081	}
4082
4083	STATIC void
4084	S_cv_dump(pTHX_ CV *cv)
4085	{
4086	#ifdef DEBUGGING
4087	CV *outside = CvOUTSIDE(cv);
4088	AV* padlist = CvPADLIST(cv);
4089	AV* pad_name;
4090	AV* pad;
4091	SV** pname;
4092	SV** ppad;
4093	I32 ix;
4094
4095	PerlIO_printf(Perl_debug_log,
4096	"\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4097	PTR2UV(cv),
4098	(CvANON(cv) ? "ANON"
4099	: (cv == PL_main_cv) ? "MAIN"
4100	: CvUNIQUE(cv) ? "UNIQUE"
4101	: CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4102	PTR2UV(outside),
4103	(!outside ? "null"
4104	: CvANON(outside) ? "ANON"
4105	: (outside == PL_main_cv) ? "MAIN"
4106	: CvUNIQUE(outside) ? "UNIQUE"
4107	: CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4108
4109	if (!padlist)
4110	return;
4111
4112	pad_name = (AV)av_fetch(padlist, 0, FALSE);
4113	pad = (AV)av_fetch(padlist, 1, FALSE);
4114	pname = AvARRAY(pad_name);
4115	ppad = AvARRAY(pad);
4116
4117	for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4118	if (SvPOK(pname[ix]))
4119	PerlIO_printf(Perl_debug_log,
4120	"\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4121	(int)ix, PTR2UV(ppad[ix]),
4122	SvFAKE(pname[ix]) ? "FAKE " : "",
4123	SvPVX(pname[ix]),
4124	(IV)I_32(SvNVX(pname[ix])),
4125	SvIVX(pname[ix]));
4126	}
4127	#endif /* DEBUGGING */
4128	}
4129
4130	STATIC CV *
4131	S_cv_clone2(pTHX_ CV proto, CV outside)
4132	{
4133	dTHR;
4134	AV* av;
4135	I32 ix;
4136	AV* protopadlist = CvPADLIST(proto);
4137	AV* protopad_name = (AV)av_fetch(protopadlist, 0, FALSE);
4138	AV* protopad = (AV)av_fetch(protopadlist, 1, FALSE);
4139	SV** pname = AvARRAY(protopad_name);
4140	SV** ppad = AvARRAY(protopad);
4141	I32 fname = AvFILLp(protopad_name);
4142	I32 fpad = AvFILLp(protopad);
4143	AV* comppadlist;
4144	CV* cv;
4145
4146	assert(!CvUNIQUE(proto));
4147
4148	ENTER;
4149	SAVECOMPPAD();
4150	SAVESPTR(PL_comppad_name);
4151	SAVESPTR(PL_compcv);
4152
4153	cv = PL_compcv = (CV*)NEWSV(1104,0);
4154	sv_upgrade((SV *)cv, SvTYPE(proto));
4155	CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4156	CvCLONED_on(cv);
4157
4158	#ifdef USE_THREADS
4159	New(666, CvMUTEXP(cv), 1, perl_mutex);
4160	MUTEX_INIT(CvMUTEXP(cv));
4161	CvOWNER(cv) = 0;
4162	#endif /* USE_THREADS */
4163	CvFILE(cv) = CvFILE(proto);
4164	CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
4165	CvSTASH(cv) = CvSTASH(proto);
4166	CvROOT(cv) = CvROOT(proto);
4167	CvSTART(cv) = CvSTART(proto);
4168	if (outside)
4169	CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
4170
4171	if (SvPOK(proto))
4172	sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4173
4174	PL_comppad_name = newAV();
4175	for (ix = fname; ix >= 0; ix--)
4176	av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4177
4178	PL_comppad = newAV();
4179
4180	comppadlist = newAV();
4181	AvREAL_off(comppadlist);
4182	av_store(comppadlist, 0, (SV*)PL_comppad_name);
4183	av_store(comppadlist, 1, (SV*)PL_comppad);
4184	CvPADLIST(cv) = comppadlist;
4185	av_fill(PL_comppad, AvFILLp(protopad));
4186	PL_curpad = AvARRAY(PL_comppad);
4187
4188	av = newAV(); /* will be @_ */
4189	av_extend(av, 0);
4190	av_store(PL_comppad, 0, (SV*)av);
4191	AvFLAGS(av) = AVf_REIFY;
4192
4193	for (ix = fpad; ix > 0; ix--) {
4194	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4195	if (namesv && namesv != &PL_sv_undef) {
4196	char name = SvPVX(namesv); / XXX */
4197	if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */
4198	I32 off = pad_findlex(name, ix, SvIVX(namesv),
4199	CvOUTSIDE(cv), cxstack_ix, 0, 0);
4200	if (!off)
4201	PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4202	else if (off != ix)
4203	Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4204	}
4205	else { /* our own lexical */
4206	SV* sv;
4207	if (*name == '&') {
4208	/* anon code -- we'll come back for it */
4209	sv = SvREFCNT_inc(ppad[ix]);
4210	}
4211	else if (*name == '@')
4212	sv = (SV*)newAV();
4213	else if (*name == '%')
4214	sv = (SV*)newHV();
4215	else
4216	sv = NEWSV(0,0);
4217	if (!SvPADBUSY(sv))
4218	SvPADMY_on(sv);
4219	PL_curpad[ix] = sv;
4220	}
4221	}
4222	else if (IS_PADGV(ppad[ix]) \|\| IS_PADCONST(ppad[ix])) {
4223	PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4224	}
4225	else {
4226	SV* sv = NEWSV(0,0);
4227	SvPADTMP_on(sv);
4228	PL_curpad[ix] = sv;
4229	}
4230	}
4231
4232	/* Now that vars are all in place, clone nested closures. */
4233
4234	for (ix = fpad; ix > 0; ix--) {
4235	SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4236	if (namesv
4237	&& namesv != &PL_sv_undef
4238	&& !(SvFLAGS(namesv) & SVf_FAKE)
4239	&& *SvPVX(namesv) == '&'
4240	&& CvCLONE(ppad[ix]))
4241	{
4242	CV kid = cv_clone2((CV)ppad[ix], cv);
4243	SvREFCNT_dec(ppad[ix]);
4244	CvCLONE_on(kid);
4245	SvPADMY_on(kid);
4246	PL_curpad[ix] = (SV*)kid;
4247	}
4248	}
4249
4250	#ifdef DEBUG_CLOSURES
4251	PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4252	cv_dump(outside);
4253	PerlIO_printf(Perl_debug_log, " from:\n");
4254	cv_dump(proto);
4255	PerlIO_printf(Perl_debug_log, " to:\n");
4256	cv_dump(cv);
4257	#endif
4258
4259	LEAVE;
4260	return cv;
4261	}
4262
4263	CV *
4264	Perl_cv_clone(pTHX_ CV *proto)
4265	{
4266	CV *cv;
4267	LOCK_CRED_MUTEX; /* XXX create separate mutex */
4268	cv = cv_clone2(proto, CvOUTSIDE(proto));
4269	UNLOCK_CRED_MUTEX; /* XXX create separate mutex */
4270	return cv;
4271	}
4272
4273	void
4274	Perl_cv_ckproto(pTHX_ CV cv, GV gv, char *p)
4275	{
4276	dTHR;
4277
4278	if (((!p != !SvPOK(cv)) \|\| (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4279	SV* msg = sv_newmortal();
4280	SV* name = Nullsv;
4281
4282	if (gv)
4283	gv_efullname3(name = sv_newmortal(), gv, Nullch);
4284	sv_setpv(msg, "Prototype mismatch:");
4285	if (name)
4286	Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4287	if (SvPOK(cv))
4288	Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4289	sv_catpv(msg, " vs ");
4290	if (p)
4291	Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4292	else
4293	sv_catpv(msg, "none");
4294	Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4295	}
4296	}
4297
4298	SV *
4299	Perl_cv_const_sv(pTHX_ CV *cv)
4300	{
4301	if (!cv \|\| !SvPOK(cv) \|\| SvCUR(cv))
4302	return Nullsv;
4303	return op_const_sv(CvSTART(cv), cv);
4304	}
4305
4306	SV *
4307	Perl_op_const_sv(pTHX_ OP o, CV cv)
4308	{
4309	SV *sv = Nullsv;
4310
4311	if (!o)
4312	return Nullsv;
4313
4314	if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4315	o = cLISTOPo->op_first->op_sibling;
4316
4317	for (; o; o = o->op_next) {
4318	OPCODE type = o->op_type;
4319
4320	if (sv && o->op_next == o)
4321	return sv;
4322	if (type == OP_NEXTSTATE \|\| type == OP_NULL \|\| type == OP_PUSHMARK)
4323	continue;
4324	if (type == OP_LEAVESUB \|\| type == OP_RETURN)
4325	break;
4326	if (sv)
4327	return Nullsv;
4328	if (type == OP_CONST && cSVOPo->op_sv)
4329	sv = cSVOPo->op_sv;
4330	else if ((type == OP_PADSV \|\| type == OP_CONST) && cv) {
4331	AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4332	sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4333	if (!sv \|\| (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
4334	return Nullsv;
4335	}
4336	else
4337	return Nullsv;
4338	}
4339	if (sv)
4340	SvREADONLY_on(sv);
4341	return sv;
4342	}
4343
4344	void
4345	Perl_newMYSUB(pTHX_ I32 floor, OP o, OP proto, OP attrs, OP block)
4346	{
4347	if (o)
4348	SAVEFREEOP(o);
4349	if (proto)
4350	SAVEFREEOP(proto);
4351	if (attrs)
4352	SAVEFREEOP(attrs);
4353	if (block)
4354	SAVEFREEOP(block);
4355	Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4356	}
4357
4358	CV *
4359	Perl_newSUB(pTHX_ I32 floor, OP o, OP proto, OP *block)
4360	{
4361	return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4362	}
4363
4364	CV *
4365	Perl_newATTRSUB(pTHX_ I32 floor, OP o, OP proto, OP attrs, OP block)
4366	{
4367	dTHR;
4368	STRLEN n_a;
4369	char *name;
4370	char *aname;
4371	GV *gv;
4372	char ps = proto ? SvPVx(((SVOP)proto)->op_sv, n_a) : Nullch;
4373	register CV *cv=0;
4374	I32 ix;
4375
4376	name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4377	if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4378	SV *sv = sv_newmortal();
4379	Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4380	CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4381	aname = SvPVX(sv);
4382	}
4383	else
4384	aname = Nullch;
4385	gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4386	GV_ADDMULTI \| ((block \|\| attrs) ? 0 : GV_NOINIT),
4387	SVt_PVCV);
4388
4389	if (o)
4390	SAVEFREEOP(o);
4391	if (proto)
4392	SAVEFREEOP(proto);
4393	if (attrs)
4394	SAVEFREEOP(attrs);
4395
4396	if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4397	maximum a prototype before. */
4398	if (SvTYPE(gv) > SVt_NULL) {
4399	if (!SvPOK((SV)gv) && !(SvIOK((SV)gv) && SvIVX((SV*)gv) == -1)
4400	&& ckWARN_d(WARN_PROTOTYPE))
4401	{
4402	Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4403	}
4404	cv_ckproto((CV*)gv, NULL, ps);
4405	}
4406	if (ps)
4407	sv_setpv((SV*)gv, ps);
4408	else
4409	sv_setiv((SV*)gv, -1);
4410	SvREFCNT_dec(PL_compcv);
4411	cv = PL_compcv = NULL;
4412	PL_sub_generation++;
4413	goto noblock;
4414	}
4415
4416	if (!name \|\| GvCVGEN(gv))
4417	cv = Nullcv;
4418	else if ((cv = GvCV(gv))) {
4419	cv_ckproto(cv, gv, ps);
4420	/* already defined (or promised)? */
4421	if (CvROOT(cv) \|\| CvXSUB(cv) \|\| GvASSUMECV(gv)) {
4422	SV* const_sv;
4423	bool const_changed = TRUE;
4424	if (!block && !attrs) {
4425	/* just a "sub foo;" when &foo is already defined */
4426	SAVEFREESV(PL_compcv);
4427	goto done;
4428	}
4429	/* ahem, death to those who redefine active sort subs */
4430	if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4431	Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4432	if (!block)
4433	goto withattrs;
4434	if ((const_sv = cv_const_sv(cv)))
4435	const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
4436	if ((const_sv \|\| const_changed) && ckWARN(WARN_REDEFINE))
4437	{
4438	line_t oldline = CopLINE(PL_curcop);
4439	CopLINE_set(PL_curcop, PL_copline);
4440	Perl_warner(aTHX_ WARN_REDEFINE,
4441	const_sv ? "Constant subroutine %s redefined"
4442	: "Subroutine %s redefined", name);
4443	CopLINE_set(PL_curcop, oldline);
4444	}
4445	SvREFCNT_dec(cv);
4446	cv = Nullcv;
4447	}
4448	}
4449	withattrs:
4450	if (attrs) {
4451	HV *stash;
4452	SV *rcv;
4453
4454	/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4455	* before we clobber PL_compcv.
4456	*/
4457	if (cv && !block) {
4458	rcv = (SV*)cv;
4459	if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4460	stash = GvSTASH(CvGV(cv));
4461	else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4462	stash = CvSTASH(cv);
4463	else
4464	stash = PL_curstash;
4465	}
4466	else {
4467	/* possibly about to re-define existing subr -- ignore old cv */
4468	rcv = (SV*)PL_compcv;
4469	if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4470	stash = GvSTASH(gv);
4471	else
4472	stash = PL_curstash;
4473	}
4474	apply_attrs(stash, rcv, attrs);
4475	}
4476	if (cv) { /* must reuse cv if autoloaded */
4477	if (!block) {
4478	/* got here with just attrs -- work done, so bug out */
4479	SAVEFREESV(PL_compcv);
4480	goto done;
4481	}
4482	cv_undef(cv);
4483	CvFLAGS(cv) = CvFLAGS(PL_compcv);
4484	CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4485	CvOUTSIDE(PL_compcv) = 0;
4486	CvPADLIST(cv) = CvPADLIST(PL_compcv);
4487	CvPADLIST(PL_compcv) = 0;
4488	if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4489	CvOUTSIDE(PL_compcv) = (CV)SvREFCNT_inc((SV)cv);
4490	SvREFCNT_dec(PL_compcv);
4491	}
4492	else {
4493	cv = PL_compcv;
4494	if (name) {
4495	GvCV(gv) = cv;
4496	GvCVGEN(gv) = 0;
4497	PL_sub_generation++;
4498	}
4499	}
4500	CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4501	CvFILE(cv) = CopFILE(PL_curcop);
4502	CvSTASH(cv) = PL_curstash;
4503	#ifdef USE_THREADS
4504	CvOWNER(cv) = 0;
4505	if (!CvMUTEXP(cv)) {
4506	New(666, CvMUTEXP(cv), 1, perl_mutex);
4507	MUTEX_INIT(CvMUTEXP(cv));
4508	}
4509	#endif /* USE_THREADS */
4510
4511	if (ps)
4512	sv_setpv((SV*)cv, ps);
4513
4514	if (PL_error_count) {
4515	op_free(block);
4516	block = Nullop;
4517	if (name) {
4518	char *s = strrchr(name, ':');
4519	s = s ? s+1 : name;
4520	if (strEQ(s, "BEGIN")) {
4521	char *not_safe =
4522	"BEGIN not safe after errors--compilation aborted";
4523	if (PL_in_eval & EVAL_KEEPERR)
4524	Perl_croak(aTHX_ not_safe);
4525	else {
4526	/* force display of errors found but not reported */
4527	sv_catpv(ERRSV, not_safe);
4528	Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4529	}
4530	}
4531	}
4532	}
4533	if (!block) {
4534	noblock:
4535	PL_copline = NOLINE;
4536	LEAVE_SCOPE(floor);
4537	return cv;
4538	}
4539
4540	if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4541	av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4542
4543	if (CvLVALUE(cv)) {
4544	CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
4545	}
4546	else {
4547	CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4548	}
4549	CvROOT(cv)->op_private \|= OPpREFCOUNTED;
4550	OpREFCNT_set(CvROOT(cv), 1);
4551	CvSTART(cv) = LINKLIST(CvROOT(cv));
4552	CvROOT(cv)->op_next = 0;
4553	peep(CvSTART(cv));
4554
4555	/* now that optimizer has done its work, adjust pad values */
4556	if (CvCLONE(cv)) {
4557	SV **namep = AvARRAY(PL_comppad_name);
4558	for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4559	SV *namesv;
4560
4561	if (SvIMMORTAL(PL_curpad[ix]) \|\| IS_PADGV(PL_curpad[ix]) \|\| IS_PADCONST(PL_curpad[ix]))
4562	continue;
4563	/*
4564	* The only things that a clonable function needs in its
4565	* pad are references to outer lexicals and anonymous subs.
4566	* The rest are created anew during cloning.
4567	*/
4568	if (!((namesv = namep[ix]) != Nullsv &&
4569	namesv != &PL_sv_undef &&
4570	(SvFAKE(namesv) \|\|
4571	*SvPVX(namesv) == '&')))
4572	{
4573	SvREFCNT_dec(PL_curpad[ix]);
4574	PL_curpad[ix] = Nullsv;
4575	}
4576	}
4577	}
4578	else {
4579	AV av = newAV(); / Will be @_ */
4580	av_extend(av, 0);
4581	av_store(PL_comppad, 0, (SV*)av);
4582	AvFLAGS(av) = AVf_REIFY;
4583
4584	for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4585	if (SvIMMORTAL(PL_curpad[ix]) \|\| IS_PADGV(PL_curpad[ix]) \|\| IS_PADCONST(PL_curpad[ix]))
4586	continue;
4587	if (!SvPADMY(PL_curpad[ix]))
4588	SvPADTMP_on(PL_curpad[ix]);
4589	}
4590	}
4591
4592	if (name \|\| aname) {
4593	char *s;
4594	char *tname = (name ? name : aname);
4595
4596	if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4597	SV *sv = NEWSV(0,0);
4598	SV *tmpstr = sv_newmortal();
4599	GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4600	CV *pcv;
4601	HV *hv;
4602
4603	Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4604	CopFILE(PL_curcop),
4605	(long)PL_subline, (long)CopLINE(PL_curcop));
4606	gv_efullname3(tmpstr, gv, Nullch);
4607	hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4608	hv = GvHVn(db_postponed);
4609	if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4610	&& (pcv = GvCV(db_postponed)))
4611	{
4612	dSP;
4613	PUSHMARK(SP);
4614	XPUSHs(tmpstr);
4615	PUTBACK;
4616	call_sv((SV*)pcv, G_DISCARD);
4617	}
4618	}
4619
4620	if ((s = strrchr(tname,':')))
4621	s++;
4622	else
4623	s = tname;
4624
4625	if (s != 'B' && s != 'E' && s != 'C' && s != 'I')
4626	goto done;
4627
4628	if (strEQ(s, "BEGIN")) {
4629	I32 oldscope = PL_scopestack_ix;
4630	ENTER;
4631	SAVECOPFILE(&PL_compiling);
4632	SAVECOPLINE(&PL_compiling);
4633	save_svref(&PL_rs);
4634	sv_setsv(PL_rs, PL_nrs);
4635
4636	if (!PL_beginav)
4637	PL_beginav = newAV();
4638	DEBUG_x( dump_sub(gv) );
4639	av_push(PL_beginav, SvREFCNT_inc(cv));
4640	GvCV(gv) = 0;
4641	call_list(oldscope, PL_beginav);
4642
4643	PL_curcop = &PL_compiling;
4644	PL_compiling.op_private = PL_hints;
4645	LEAVE;
4646	}
4647	else if (strEQ(s, "END") && !PL_error_count) {
4648	if (!PL_endav)
4649	PL_endav = newAV();
4650	DEBUG_x( dump_sub(gv) );
4651	av_unshift(PL_endav, 1);
4652	av_store(PL_endav, 0, SvREFCNT_inc(cv));
4653	GvCV(gv) = 0;
4654	}
4655	else if (strEQ(s, "CHECK") && !PL_error_count) {
4656	if (!PL_checkav)
4657	PL_checkav = newAV();
4658	DEBUG_x( dump_sub(gv) );
4659	if (PL_main_start && ckWARN(WARN_VOID))
4660	Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4661	av_unshift(PL_checkav, 1);
4662	av_store(PL_checkav, 0, SvREFCNT_inc(cv));
4663	GvCV(gv) = 0;
4664	}
4665	else if (strEQ(s, "INIT") && !PL_error_count) {
4666	if (!PL_initav)
4667	PL_initav = newAV();
4668	DEBUG_x( dump_sub(gv) );
4669	if (PL_main_start && ckWARN(WARN_VOID))
4670	Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4671	av_push(PL_initav, SvREFCNT_inc(cv));
4672	GvCV(gv) = 0;
4673	}
4674	}
4675
4676	done:
4677	PL_copline = NOLINE;
4678	LEAVE_SCOPE(floor);
4679	return cv;
4680	}
4681
4682	/* XXX unsafe for threads if eval_owner isn't held */
4683	/*
4684	=for apidoc newCONSTSUB
4685
4686	Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4687	eligible for inlining at compile-time.
4688
4689	=cut
4690	*/
4691
4692	void
4693	Perl_newCONSTSUB(pTHX_ HV stash, char name, SV *sv)
4694	{
4695	dTHR;
4696
4697	ENTER;
4698	SAVECOPLINE(PL_curcop);
4699	SAVEHINTS();
4700
4701	CopLINE_set(PL_curcop, PL_copline);
4702	PL_hints &= ~HINT_BLOCK_SCOPE;
4703
4704	if (stash) {
4705	SAVESPTR(PL_curstash);
4706	SAVECOPSTASH(PL_curcop);
4707	PL_curstash = stash;
4708	#ifdef USE_ITHREADS
4709	CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4710	#else
4711	CopSTASH(PL_curcop) = stash;
4712	#endif
4713	}
4714
4715	newATTRSUB(
4716	start_subparse(FALSE, 0),
4717	newSVOP(OP_CONST, 0, newSVpv(name,0)),
4718	newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
4719	Nullop,
4720	newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
4721	);
4722
4723	LEAVE;
4724	}
4725
4726	/*
4727	=for apidoc U\|\|newXS
4728
4729	Used by C<xsubpp> to hook up XSUBs as Perl subs.
4730
4731	=cut
4732	*/
4733
4734	CV *
4735	Perl_newXS(pTHX_ char name, XSUBADDR_t subaddr, char filename)
4736	{
4737	dTHR;
4738	GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4739	register CV *cv;
4740
4741	if ((cv = (name ? GvCV(gv) : Nullcv))) {
4742	if (GvCVGEN(gv)) {
4743	/* just a cached method */
4744	SvREFCNT_dec(cv);
4745	cv = 0;
4746	}
4747	else if (CvROOT(cv) \|\| CvXSUB(cv) \|\| GvASSUMECV(gv)) {
4748	/* already defined (or promised) */
4749	if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4750	&& HvNAME(GvSTASH(CvGV(cv)))
4751	&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4752	line_t oldline = CopLINE(PL_curcop);
4753	if (PL_copline != NOLINE)
4754	CopLINE_set(PL_curcop, PL_copline);
4755	Perl_warner(aTHX_ WARN_REDEFINE, "Subroutine %s redefined",name);
4756	CopLINE_set(PL_curcop, oldline);
4757	}
4758	SvREFCNT_dec(cv);
4759	cv = 0;
4760	}
4761	}
4762
4763	if (cv) /* must reuse cv if autoloaded */
4764	cv_undef(cv);
4765	else {
4766	cv = (CV*)NEWSV(1105,0);
4767	sv_upgrade((SV *)cv, SVt_PVCV);
4768	if (name) {
4769	GvCV(gv) = cv;
4770	GvCVGEN(gv) = 0;
4771	PL_sub_generation++;
4772	}
4773	}
4774	CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4775	#ifdef USE_THREADS
4776	New(666, CvMUTEXP(cv), 1, perl_mutex);
4777	MUTEX_INIT(CvMUTEXP(cv));
4778	CvOWNER(cv) = 0;
4779	#endif /* USE_THREADS */
4780	(void)gv_fetchfile(filename);
4781	CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4782	an external constant string */
4783	CvXSUB(cv) = subaddr;
4784
4785	if (name) {
4786	char *s = strrchr(name,':');
4787	if (s)
4788	s++;
4789	else
4790	s = name;
4791
4792	if (s != 'B' && s != 'E' && s != 'C' && s != 'I')
4793	goto done;
4794
4795	if (strEQ(s, "BEGIN")) {
4796	if (!PL_beginav)
4797	PL_beginav = newAV();
4798	av_push(PL_beginav, SvREFCNT_inc(cv));
4799	GvCV(gv) = 0;
4800	}
4801	else if (strEQ(s, "END")) {
4802	if (!PL_endav)
4803	PL_endav = newAV();
4804	av_unshift(PL_endav, 1);
4805	av_store(PL_endav, 0, SvREFCNT_inc(cv));
4806	GvCV(gv) = 0;
4807	}
4808	else if (strEQ(s, "CHECK")) {
4809	if (!PL_checkav)
4810	PL_checkav = newAV();
4811	if (PL_main_start && ckWARN(WARN_VOID))
4812	Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4813	av_unshift(PL_checkav, 1);
4814	av_store(PL_checkav, 0, SvREFCNT_inc(cv));
4815	GvCV(gv) = 0;
4816	}
4817	else if (strEQ(s, "INIT")) {
4818	if (!PL_initav)
4819	PL_initav = newAV();
4820	if (PL_main_start && ckWARN(WARN_VOID))
4821	Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4822	av_push(PL_initav, SvREFCNT_inc(cv));
4823	GvCV(gv) = 0;
4824	}
4825	}
4826	else
4827	CvANON_on(cv);
4828
4829	done:
4830	return cv;
4831	}
4832
4833	void
4834	Perl_newFORM(pTHX_ I32 floor, OP o, OP block)
4835	{
4836	dTHR;
4837	register CV *cv;
4838	char *name;
4839	GV *gv;
4840	I32 ix;
4841	STRLEN n_a;
4842
4843	if (o)
4844	name = SvPVx(cSVOPo->op_sv, n_a);
4845	else
4846	name = "STDOUT";
4847	gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4848	GvMULTI_on(gv);
4849	if ((cv = GvFORM(gv))) {
4850	if (ckWARN(WARN_REDEFINE)) {
4851	line_t oldline = CopLINE(PL_curcop);
4852
4853	CopLINE_set(PL_curcop, PL_copline);
4854	Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
4855	CopLINE_set(PL_curcop, oldline);
4856	}
4857	SvREFCNT_dec(cv);
4858	}
4859	cv = PL_compcv;
4860	GvFORM(gv) = cv;
4861	CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4862	CvFILE(cv) = CopFILE(PL_curcop);
4863
4864	for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4865	if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
4866	SvPADTMP_on(PL_curpad[ix]);
4867	}
4868
4869	CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4870	CvROOT(cv)->op_private \|= OPpREFCOUNTED;
4871	OpREFCNT_set(CvROOT(cv), 1);
4872	CvSTART(cv) = LINKLIST(CvROOT(cv));
4873	CvROOT(cv)->op_next = 0;
4874	peep(CvSTART(cv));
4875	op_free(o);
4876	PL_copline = NOLINE;
4877	LEAVE_SCOPE(floor);
4878	}
4879
4880	OP *
4881	Perl_newANONLIST(pTHX_ OP *o)
4882	{
4883	return newUNOP(OP_REFGEN, 0,
4884	mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4885	}
4886
4887	OP *
4888	Perl_newANONHASH(pTHX_ OP *o)
4889	{
4890	return newUNOP(OP_REFGEN, 0,
4891	mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4892	}
4893
4894	OP *
4895	Perl_newANONSUB(pTHX_ I32 floor, OP proto, OP block)
4896	{
4897	return newANONATTRSUB(floor, proto, Nullop, block);
4898	}
4899
4900	OP *
4901	Perl_newANONATTRSUB(pTHX_ I32 floor, OP proto, OP attrs, OP *block)
4902	{
4903	return newUNOP(OP_REFGEN, 0,
4904	newSVOP(OP_ANONCODE, 0,
4905	(SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4906	}
4907
4908	OP *
4909	Perl_oopsAV(pTHX_ OP *o)
4910	{
4911	switch (o->op_type) {
4912	case OP_PADSV:
4913	o->op_type = OP_PADAV;
4914	o->op_ppaddr = PL_ppaddr[OP_PADAV];
4915	return ref(o, OP_RV2AV);
4916
4917	case OP_RV2SV:
4918	o->op_type = OP_RV2AV;
4919	o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4920	ref(o, OP_RV2AV);
4921	break;
4922
4923	default:
4924	if (ckWARN_d(WARN_INTERNAL))
4925	Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
4926	break;
4927	}
4928	return o;
4929	}
4930
4931	OP *
4932	Perl_oopsHV(pTHX_ OP *o)
4933	{
4934	dTHR;
4935
4936	switch (o->op_type) {
4937	case OP_PADSV:
4938	case OP_PADAV:
4939	o->op_type = OP_PADHV;
4940	o->op_ppaddr = PL_ppaddr[OP_PADHV];
4941	return ref(o, OP_RV2HV);
4942
4943	case OP_RV2SV:
4944	case OP_RV2AV:
4945	o->op_type = OP_RV2HV;
4946	o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4947	ref(o, OP_RV2HV);
4948	break;
4949
4950	default:
4951	if (ckWARN_d(WARN_INTERNAL))
4952	Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
4953	break;
4954	}
4955	return o;
4956	}
4957
4958	OP *
4959	Perl_newAVREF(pTHX_ OP *o)
4960	{
4961	if (o->op_type == OP_PADANY) {
4962	o->op_type = OP_PADAV;
4963	o->op_ppaddr = PL_ppaddr[OP_PADAV];
4964	return o;
4965	}
4966	return newUNOP(OP_RV2AV, 0, scalar(o));
4967	}
4968
4969	OP *
4970	Perl_newGVREF(pTHX_ I32 type, OP *o)
4971	{
4972	if (type == OP_MAPSTART \|\| type == OP_GREPSTART \|\| type == OP_SORT)
4973	return newUNOP(OP_NULL, 0, o);
4974	return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4975	}
4976
4977	OP *
4978	Perl_newHVREF(pTHX_ OP *o)
4979	{
4980	if (o->op_type == OP_PADANY) {
4981	o->op_type = OP_PADHV;
4982	o->op_ppaddr = PL_ppaddr[OP_PADHV];
4983	return o;
4984	}
4985	return newUNOP(OP_RV2HV, 0, scalar(o));
4986	}
4987
4988	OP *
4989	Perl_oopsCV(pTHX_ OP *o)
4990	{
4991	Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4992	/* STUB */
4993	return o;
4994	}
4995
4996	OP *
4997	Perl_newCVREF(pTHX_ I32 flags, OP *o)
4998	{
4999	return newUNOP(OP_RV2CV, flags, scalar(o));
5000	}
5001
5002	OP *
5003	Perl_newSVREF(pTHX_ OP *o)
5004	{
5005	if (o->op_type == OP_PADANY) {
5006	o->op_type = OP_PADSV;
5007	o->op_ppaddr = PL_ppaddr[OP_PADSV];
5008	return o;
5009	}
5010	else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5011	o->op_flags \|= OPpDONE_SVREF;
5012	return o;
5013	}
5014	return newUNOP(OP_RV2SV, 0, scalar(o));
5015	}
5016
5017	/* Check routines. */
5018
5019	OP *
5020	Perl_ck_anoncode(pTHX_ OP *o)
5021	{
5022	PADOFFSET ix;
5023	SV* name;
5024
5025	name = NEWSV(1106,0);
5026	sv_upgrade(name, SVt_PVNV);
5027	sv_setpvn(name, "&", 1);
5028	SvIVX(name) = -1;
5029	SvNVX(name) = 1;
5030	ix = pad_alloc(o->op_type, SVs_PADMY);
5031	av_store(PL_comppad_name, ix, name);
5032	av_store(PL_comppad, ix, cSVOPo->op_sv);
5033	SvPADMY_on(cSVOPo->op_sv);
5034	cSVOPo->op_sv = Nullsv;
5035	cSVOPo->op_targ = ix;
5036	return o;
5037	}
5038
5039	OP *
5040	Perl_ck_bitop(pTHX_ OP *o)
5041	{
5042	o->op_private = PL_hints;
5043	return o;
5044	}
5045
5046	OP *
5047	Perl_ck_concat(pTHX_ OP *o)
5048	{
5049	if (cUNOPo->op_first->op_type == OP_CONCAT)
5050	o->op_flags \|= OPf_STACKED;
5051	return o;
5052	}
5053
5054	OP *
5055	Perl_ck_spair(pTHX_ OP *o)
5056	{
5057	if (o->op_flags & OPf_KIDS) {
5058	OP* newop;
5059	OP* kid;
5060	OPCODE type = o->op_type;
5061	o = modkids(ck_fun(o), type);
5062	kid = cUNOPo->op_first;
5063	newop = kUNOP->op_first->op_sibling;
5064	if (newop &&
5065	(newop->op_sibling \|\|
5066	!(PL_opargs[newop->op_type] & OA_RETSCALAR) \|\|
5067	newop->op_type == OP_PADAV \|\| newop->op_type == OP_PADHV \|\|
5068	newop->op_type == OP_RV2AV \|\| newop->op_type == OP_RV2HV)) {
5069
5070	return o;
5071	}
5072	op_free(kUNOP->op_first);
5073	kUNOP->op_first = newop;
5074	}
5075	o->op_ppaddr = PL_ppaddr[++o->op_type];
5076	return ck_fun(o);
5077	}
5078
5079	OP *
5080	Perl_ck_delete(pTHX_ OP *o)
5081	{
5082	o = ck_fun(o);
5083	o->op_private = 0;
5084	if (o->op_flags & OPf_KIDS) {
5085	OP *kid = cUNOPo->op_first;
5086	switch (kid->op_type) {
5087	case OP_ASLICE:
5088	o->op_flags \|= OPf_SPECIAL;
5089	/* FALL THROUGH */
5090	case OP_HSLICE:
5091	o->op_private \|= OPpSLICE;
5092	break;
5093	case OP_AELEM:
5094	o->op_flags \|= OPf_SPECIAL;
5095	/* FALL THROUGH */
5096	case OP_HELEM:
5097	break;
5098	default:
5099	Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5100	PL_op_desc[o->op_type]);
5101	}
5102	null(kid);
5103	}
5104	return o;
5105	}
5106
5107	OP *
5108	Perl_ck_eof(pTHX_ OP *o)
5109	{
5110	I32 type = o->op_type;
5111
5112	if (o->op_flags & OPf_KIDS) {
5113	if (cLISTOPo->op_first->op_type == OP_STUB) {
5114	op_free(o);
5115	o = newUNOP(type, OPf_SPECIAL,
5116	newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5117	}
5118	return ck_fun(o);
5119	}
5120	return o;
5121	}
5122
5123	OP *
5124	Perl_ck_eval(pTHX_ OP *o)
5125	{
5126	PL_hints \|= HINT_BLOCK_SCOPE;
5127	if (o->op_flags & OPf_KIDS) {
5128	SVOP kid = (SVOP)cUNOPo->op_first;
5129
5130	if (!kid) {
5131	o->op_flags &= ~OPf_KIDS;
5132	null(o);
5133	}
5134	else if (kid->op_type == OP_LINESEQ) {
5135	LOGOP *enter;
5136
5137	kid->op_next = o->op_next;
5138	cUNOPo->op_first = 0;
5139	op_free(o);
5140
5141	NewOp(1101, enter, 1, LOGOP);
5142	enter->op_type = OP_ENTERTRY;
5143	enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5144	enter->op_private = 0;
5145
5146	/* establish postfix order */
5147	enter->op_next = (OP*)enter;
5148
5149	o = prepend_elem(OP_LINESEQ, (OP)enter, (OP)kid);
5150	o->op_type = OP_LEAVETRY;
5151	o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5152	enter->op_other = o;
5153	return o;
5154	}
5155	else
5156	scalar((OP*)kid);
5157	}
5158	else {
5159	op_free(o);
5160	o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5161	}
5162	o->op_targ = (PADOFFSET)PL_hints;
5163	return o;
5164	}
5165
5166	OP *
5167	Perl_ck_exit(pTHX_ OP *o)
5168	{
5169	#ifdef VMS
5170	HV *table = GvHV(PL_hintgv);
5171	if (table) {
5172	SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5173	if (svp && svp && SvTRUE(svp))
5174	o->op_private \|= OPpEXIT_VMSISH;
5175	}
5176	#endif
5177	return ck_fun(o);
5178	}
5179
5180	OP *
5181	Perl_ck_exec(pTHX_ OP *o)
5182	{
5183	OP *kid;
5184	if (o->op_flags & OPf_STACKED) {
5185	o = ck_fun(o);
5186	kid = cUNOPo->op_first->op_sibling;
5187	if (kid->op_type == OP_RV2GV)
5188	null(kid);
5189	}
5190	else
5191	o = listkids(o);
5192	return o;
5193	}
5194
5195	OP *
5196	Perl_ck_exists(pTHX_ OP *o)
5197	{
5198	o = ck_fun(o);
5199	if (o->op_flags & OPf_KIDS) {
5200	OP *kid = cUNOPo->op_first;
5201	if (kid->op_type == OP_ENTERSUB) {
5202	(void) ref(kid, o->op_type);
5203	if (kid->op_type != OP_RV2CV && !PL_error_count)
5204	Perl_croak(aTHX_ "%s argument is not a subroutine name",
5205	PL_op_desc[o->op_type]);
5206	o->op_private \|= OPpEXISTS_SUB;
5207	}
5208	else if (kid->op_type == OP_AELEM)
5209	o->op_flags \|= OPf_SPECIAL;
5210	else if (kid->op_type != OP_HELEM)
5211	Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5212	PL_op_desc[o->op_type]);
5213	null(kid);
5214	}
5215	return o;
5216	}
5217
5218	#if 0
5219	OP *
5220	Perl_ck_gvconst(pTHX_ register OP *o)
5221	{
5222	o = fold_constants(o);
5223	if (o->op_type == OP_CONST)
5224	o->op_type = OP_GV;
5225	return o;
5226	}
5227	#endif
5228
5229	OP *
5230	Perl_ck_rvconst(pTHX_ register OP *o)
5231	{
5232	dTHR;
5233	SVOP kid = (SVOP)cUNOPo->op_first;
5234
5235	o->op_private \|= (PL_hints & HINT_STRICT_REFS);
5236	if (kid->op_type == OP_CONST) {
5237	char *name;
5238	int iscv;
5239	GV *gv;
5240	SV *kidsv = kid->op_sv;
5241	STRLEN n_a;
5242
5243	/* Is it a constant from cv_const_sv()? */
5244	if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5245	SV *rsv = SvRV(kidsv);
5246	int svtype = SvTYPE(rsv);
5247	char *badtype = Nullch;
5248
5249	switch (o->op_type) {
5250	case OP_RV2SV:
5251	if (svtype > SVt_PVMG)
5252	badtype = "a SCALAR";
5253	break;
5254	case OP_RV2AV:
5255	if (svtype != SVt_PVAV)
5256	badtype = "an ARRAY";
5257	break;
5258	case OP_RV2HV:
5259	if (svtype != SVt_PVHV) {
5260	if (svtype == SVt_PVAV) { /* pseudohash? */
5261	SV *ksv = av_fetch((AV)rsv, 0, FALSE);
5262	if (ksv && SvROK(*ksv)
5263	&& SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5264	{
5265	break;
5266	}
5267	}
5268	badtype = "a HASH";
5269	}
5270	break;
5271	case OP_RV2CV:
5272	if (svtype != SVt_PVCV)
5273	badtype = "a CODE";
5274	break;
5275	}
5276	if (badtype)
5277	Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5278	return o;
5279	}
5280	name = SvPV(kidsv, n_a);
5281	if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5282	char *badthing = Nullch;
5283	switch (o->op_type) {
5284	case OP_RV2SV:
5285	badthing = "a SCALAR";
5286	break;
5287	case OP_RV2AV:
5288	badthing = "an ARRAY";
5289	break;
5290	case OP_RV2HV:
5291	badthing = "a HASH";
5292	break;
5293	}
5294	if (badthing)
5295	Perl_croak(aTHX_
5296	"Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5297	name, badthing);
5298	}
5299	/*
5300	* This is a little tricky. We only want to add the symbol if we
5301	* didn't add it in the lexer. Otherwise we get duplicate strict
5302	* warnings. But if we didn't add it in the lexer, we must at
5303	* least pretend like we wanted to add it even if it existed before,
5304	* or we get possible typo warnings. OPpCONST_ENTERED says
5305	* whether the lexer already added THIS instance of this symbol.
5306	*/
5307	iscv = (o->op_type == OP_RV2CV) * 2;
5308	do {
5309	gv = gv_fetchpv(name,
5310	iscv \| !(kid->op_private & OPpCONST_ENTERED),
5311	iscv
5312	? SVt_PVCV
5313	: o->op_type == OP_RV2SV
5314	? SVt_PV
5315	: o->op_type == OP_RV2AV
5316	? SVt_PVAV
5317	: o->op_type == OP_RV2HV
5318	? SVt_PVHV
5319	: SVt_PVGV);
5320	} while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5321	if (gv) {
5322	kid->op_type = OP_GV;
5323	SvREFCNT_dec(kid->op_sv);
5324	#ifdef USE_ITHREADS
5325	/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5326	kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5327	GvIN_PAD_on(gv);
5328	PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5329	#else
5330	kid->op_sv = SvREFCNT_inc(gv);
5331	#endif
5332	kid->op_ppaddr = PL_ppaddr[OP_GV];
5333	}
5334	}
5335	return o;
5336	}
5337
5338	OP *
5339	Perl_ck_ftst(pTHX_ OP *o)
5340	{
5341	dTHR;
5342	I32 type = o->op_type;
5343
5344	if (o->op_flags & OPf_REF) {
5345	/* nothing */
5346	}
5347	else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5348	SVOP kid = (SVOP)cUNOPo->op_first;
5349
5350	if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5351	STRLEN n_a;
5352	OP *newop = newGVOP(type, OPf_REF,
5353	gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5354	op_free(o);
5355	o = newop;
5356	}
5357	}
5358	else {
5359	op_free(o);
5360	if (type == OP_FTTTY)
5361	o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5362	SVt_PVIO));
5363	else
5364	o = newUNOP(type, 0, newDEFSVOP());
5365	}
5366	#ifdef USE_LOCALE
5367	if (type == OP_FTTEXT \|\| type == OP_FTBINARY) {
5368	o->op_private = 0;
5369	if (PL_hints & HINT_LOCALE)
5370	o->op_private \|= OPpLOCALE;
5371	}
5372	#endif
5373	return o;
5374	}
5375
5376	OP *
5377	Perl_ck_fun(pTHX_ OP *o)
5378	{
5379	dTHR;
5380	register OP *kid;
5381	OP **tokid;
5382	OP *sibl;
5383	I32 numargs = 0;
5384	int type = o->op_type;
5385	register I32 oa = PL_opargs[type] >> OASHIFT;
5386
5387	if (o->op_flags & OPf_STACKED) {
5388	if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5389	oa &= ~OA_OPTIONAL;
5390	else
5391	return no_fh_allowed(o);
5392	}
5393
5394	if (o->op_flags & OPf_KIDS) {
5395	STRLEN n_a;
5396	tokid = &cLISTOPo->op_first;
5397	kid = cLISTOPo->op_first;
5398	if (kid->op_type == OP_PUSHMARK \|\|
5399	(kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5400	{
5401	tokid = &kid->op_sibling;
5402	kid = kid->op_sibling;
5403	}
5404	if (!kid && PL_opargs[type] & OA_DEFGV)
5405	*tokid = kid = newDEFSVOP();
5406
5407	while (oa && kid) {
5408	numargs++;
5409	sibl = kid->op_sibling;
5410	switch (oa & 7) {
5411	case OA_SCALAR:
5412	/* list seen where single (scalar) arg expected? */
5413	if (numargs == 1 && !(oa >> 4)
5414	&& kid->op_type == OP_LIST && type != OP_SCALAR)
5415	{
5416	return too_many_arguments(o,PL_op_desc[type]);
5417	}
5418	scalar(kid);
5419	break;
5420	case OA_LIST:
5421	if (oa < 16) {
5422	kid = 0;
5423	continue;
5424	}
5425	else
5426	list(kid);
5427	break;
5428	case OA_AVREF:
5429	if (kid->op_type == OP_CONST &&
5430	(kid->op_private & OPpCONST_BARE))
5431	{
5432	char name = SvPVx(((SVOP)kid)->op_sv, n_a);
5433	OP *newop = newAVREF(newGVOP(OP_GV, 0,
5434	gv_fetchpv(name, TRUE, SVt_PVAV) ));
5435	if (ckWARN(WARN_DEPRECATED))
5436	Perl_warner(aTHX_ WARN_DEPRECATED,
5437	"Array @%s missing the @ in argument %"IVdf" of %s()",
5438	name, (IV)numargs, PL_op_desc[type]);
5439	op_free(kid);
5440	kid = newop;
5441	kid->op_sibling = sibl;
5442	*tokid = kid;
5443	}
5444	else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5445	bad_type(numargs, "array", PL_op_desc[type], kid);
5446	mod(kid, type);
5447	break;
5448	case OA_HVREF:
5449	if (kid->op_type == OP_CONST &&
5450	(kid->op_private & OPpCONST_BARE))
5451	{
5452	char name = SvPVx(((SVOP)kid)->op_sv, n_a);
5453	OP *newop = newHVREF(newGVOP(OP_GV, 0,
5454	gv_fetchpv(name, TRUE, SVt_PVHV) ));
5455	if (ckWARN(WARN_DEPRECATED))
5456	Perl_warner(aTHX_ WARN_DEPRECATED,
5457	"Hash %%%s missing the %% in argument %"IVdf" of %s()",
5458	name, (IV)numargs, PL_op_desc[type]);
5459	op_free(kid);
5460	kid = newop;
5461	kid->op_sibling = sibl;
5462	*tokid = kid;
5463	}
5464	else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5465	bad_type(numargs, "hash", PL_op_desc[type], kid);
5466	mod(kid, type);
5467	break;
5468	case OA_CVREF:
5469	{
5470	OP *newop = newUNOP(OP_NULL, 0, kid);
5471	kid->op_sibling = 0;
5472	linklist(kid);
5473	newop->op_next = newop;
5474	kid = newop;
5475	kid->op_sibling = sibl;
5476	*tokid = kid;
5477	}
5478	break;
5479	case OA_FILEREF:
5480	if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5481	if (kid->op_type == OP_CONST &&
5482	(kid->op_private & OPpCONST_BARE))
5483	{
5484	OP *newop = newGVOP(OP_GV, 0,
5485	gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5486	SVt_PVIO) );
5487	op_free(kid);
5488	kid = newop;
5489	}
5490	else if (kid->op_type == OP_READLINE) {
5491	/* neophyte patrol: open(<FH>), close(<FH>) etc. */
5492	bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5493	}
5494	else {
5495	I32 flags = OPf_SPECIAL;
5496	I32 priv = 0;
5497	PADOFFSET targ = 0;
5498
5499	/* is this op a FH constructor? */
5500	if (is_handle_constructor(o,numargs)) {
5501	char *name = Nullch;
5502	STRLEN len;
5503
5504	flags = 0;
5505	/* Set a flag to tell rv2gv to vivify
5506	* need to "prove" flag does not mean something
5507	* else already - NI-S 1999/05/07
5508	*/
5509	priv = OPpDEREF;
5510	if (kid->op_type == OP_PADSV) {
5511	SV **namep = av_fetch(PL_comppad_name,
5512	kid->op_targ, 4);
5513	if (namep && *namep)
5514	name = SvPV(*namep, len);
5515	}
5516	else if (kid->op_type == OP_RV2SV
5517	&& kUNOP->op_first->op_type == OP_GV)
5518	{
5519	GV *gv = cGVOPx_gv(kUNOP->op_first);
5520	name = GvNAME(gv);
5521	len = GvNAMELEN(gv);
5522	}
5523	else if (kid->op_type == OP_AELEM
5524	\|\| kid->op_type == OP_HELEM)
5525	{
5526	name = "__ANONIO__";
5527	len = 10;
5528	mod(kid,type);
5529	}
5530	if (name) {
5531	SV *namesv;
5532	targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5533	namesv = PL_curpad[targ];
5534	(void)SvUPGRADE(namesv, SVt_PV);
5535	if (*name != '$')
5536	sv_setpvn(namesv, "$", 1);
5537	sv_catpvn(namesv, name, len);
5538	}
5539	}
5540	kid->op_sibling = 0;
5541	kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5542	kid->op_targ = targ;
5543	kid->op_private \|= priv;
5544	}
5545	kid->op_sibling = sibl;
5546	*tokid = kid;
5547	}
5548	scalar(kid);
5549	break;
5550	case OA_SCALARREF:
5551	mod(scalar(kid), type);
5552	break;
5553	}
5554	oa >>= 4;
5555	tokid = &kid->op_sibling;
5556	kid = kid->op_sibling;
5557	}
5558	o->op_private \|= numargs;
5559	if (kid)
5560	return too_many_arguments(o,PL_op_desc[o->op_type]);
5561	listkids(o);
5562	}
5563	else if (PL_opargs[type] & OA_DEFGV) {
5564	op_free(o);
5565	return newUNOP(type, 0, newDEFSVOP());
5566	}
5567
5568	if (oa) {
5569	while (oa & OA_OPTIONAL)
5570	oa >>= 4;
5571	if (oa && oa != OA_LIST)
5572	return too_few_arguments(o,PL_op_desc[o->op_type]);
5573	}
5574	return o;
5575	}
5576
5577	OP *
5578	Perl_ck_glob(pTHX_ OP *o)
5579	{
5580	GV *gv;
5581
5582	o = ck_fun(o);
5583	if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5584	append_elem(OP_GLOB, o, newDEFSVOP());
5585
5586	if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5587	gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5588
5589	#if !defined(PERL_EXTERNAL_GLOB)
5590	/* XXX this can be tightened up and made more failsafe. */
5591	if (!gv) {
5592	ENTER;
5593	Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5594	/* null-terminated import list */
5595	newSVpvn(":globally", 9), Nullsv);
5596	gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5597	LEAVE;
5598	}
5599	#endif /* PERL_EXTERNAL_GLOB */
5600
5601	if (gv && GvIMPORTED_CV(gv)) {
5602	append_elem(OP_GLOB, o,
5603	newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5604	o->op_type = OP_LIST;
5605	o->op_ppaddr = PL_ppaddr[OP_LIST];
5606	cLISTOPo->op_first->op_type = OP_PUSHMARK;
5607	cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5608	o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5609	append_elem(OP_LIST, o,
5610	scalar(newUNOP(OP_RV2CV, 0,
5611	newGVOP(OP_GV, 0, gv)))));
5612	o = newUNOP(OP_NULL, 0, ck_subr(o));
5613	o->op_targ = OP_GLOB; /* hint at what it used to be */
5614	return o;
5615	}
5616	gv = newGVgen("main");
5617	gv_IOadd(gv);
5618	append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5619	scalarkids(o);
5620	return o;
5621	}
5622
5623	OP *
5624	Perl_ck_grep(pTHX_ OP *o)
5625	{
5626	LOGOP *gwop;
5627	OP *kid;
5628	OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5629
5630	o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5631	NewOp(1101, gwop, 1, LOGOP);
5632
5633	if (o->op_flags & OPf_STACKED) {
5634	OP* k;
5635	o = ck_sort(o);
5636	kid = cLISTOPo->op_first->op_sibling;
5637	for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5638	kid = k;
5639	}
5640	kid->op_next = (OP*)gwop;
5641	o->op_flags &= ~OPf_STACKED;
5642	}
5643	kid = cLISTOPo->op_first->op_sibling;
5644	if (type == OP_MAPWHILE)
5645	list(kid);
5646	else
5647	scalar(kid);
5648	o = ck_fun(o);
5649	if (PL_error_count)
5650	return o;
5651	kid = cLISTOPo->op_first->op_sibling;
5652	if (kid->op_type != OP_NULL)
5653	Perl_croak(aTHX_ "panic: ck_grep");
5654	kid = kUNOP->op_first;
5655
5656	gwop->op_type = type;
5657	gwop->op_ppaddr = PL_ppaddr[type];
5658	gwop->op_first = listkids(o);
5659	gwop->op_flags \|= OPf_KIDS;
5660	gwop->op_private = 1;
5661	gwop->op_other = LINKLIST(kid);
5662	gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5663	kid->op_next = (OP*)gwop;
5664
5665	kid = cLISTOPo->op_first->op_sibling;
5666	if (!kid \|\| !kid->op_sibling)
5667	return too_few_arguments(o,PL_op_desc[o->op_type]);
5668	for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5669	mod(kid, OP_GREPSTART);
5670
5671	return (OP*)gwop;
5672	}
5673
5674	OP *
5675	Perl_ck_index(pTHX_ OP *o)
5676	{
5677	if (o->op_flags & OPf_KIDS) {
5678	OP kid = cLISTOPo->op_first->op_sibling; / get past pushmark */
5679	if (kid)
5680	kid = kid->op_sibling; /* get past "big" */
5681	if (kid && kid->op_type == OP_CONST)
5682	fbm_compile(((SVOP*)kid)->op_sv, 0);
5683	}
5684	return ck_fun(o);
5685	}
5686
5687	OP *
5688	Perl_ck_lengthconst(pTHX_ OP *o)
5689	{
5690	/* XXX length optimization goes here */
5691	return ck_fun(o);
5692	}
5693
5694	OP *
5695	Perl_ck_lfun(pTHX_ OP *o)
5696	{
5697	OPCODE type = o->op_type;
5698	return modkids(ck_fun(o), type);
5699	}
5700
5701	OP *
5702	Perl_ck_defined(pTHX_ OP o) / 19990527 MJD */
5703	{
5704	dTHR;
5705	if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5706	switch (cUNOPo->op_first->op_type) {
5707	case OP_RV2AV:
5708	break; /* Globals via GV can be undef */
5709	case OP_PADAV:
5710	case OP_AASSIGN: /* Is this a good idea? */
5711	Perl_warner(aTHX_ WARN_DEPRECATED,
5712	"defined(@array) is deprecated");
5713	Perl_warner(aTHX_ WARN_DEPRECATED,
5714	"\t(Maybe you should just omit the defined()?)\n");
5715	break;
5716	case OP_RV2HV:
5717	break; /* Globals via GV can be undef */
5718	case OP_PADHV:
5719	Perl_warner(aTHX_ WARN_DEPRECATED,
5720	"defined(%%hash) is deprecated");
5721	Perl_warner(aTHX_ WARN_DEPRECATED,
5722	"\t(Maybe you should just omit the defined()?)\n");
5723	break;
5724	default:
5725	/* no warning */
5726	break;
5727	}
5728	}
5729	return ck_rfun(o);
5730	}
5731
5732	OP *
5733	Perl_ck_rfun(pTHX_ OP *o)
5734	{
5735	OPCODE type = o->op_type;
5736	return refkids(ck_fun(o), type);
5737	}
5738
5739	OP *
5740	Perl_ck_listiob(pTHX_ OP *o)
5741	{
5742	register OP *kid;
5743
5744	kid = cLISTOPo->op_first;
5745	if (!kid) {
5746	o = force_list(o);
5747	kid = cLISTOPo->op_first;
5748	}
5749	if (kid->op_type == OP_PUSHMARK)
5750	kid = kid->op_sibling;
5751	if (kid && o->op_flags & OPf_STACKED)
5752	kid = kid->op_sibling;
5753	else if (kid && !kid->op_sibling) { /* print HANDLE; */
5754	if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5755	o->op_flags \|= OPf_STACKED; /* make it a filehandle */
5756	kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5757	cLISTOPo->op_first->op_sibling = kid;
5758	cLISTOPo->op_last = kid;
5759	kid = kid->op_sibling;
5760	}
5761	}
5762
5763	if (!kid)
5764	append_elem(o->op_type, o, newDEFSVOP());
5765
5766	o = listkids(o);
5767
5768	o->op_private = 0;
5769	#ifdef USE_LOCALE
5770	if (PL_hints & HINT_LOCALE)
5771	o->op_private \|= OPpLOCALE;
5772	#endif
5773
5774	return o;
5775	}
5776
5777	OP *
5778	Perl_ck_fun_locale(pTHX_ OP *o)
5779	{
5780	o = ck_fun(o);
5781
5782	o->op_private = 0;
5783	#ifdef USE_LOCALE
5784	if (PL_hints & HINT_LOCALE)
5785	o->op_private \|= OPpLOCALE;
5786	#endif
5787
5788	return o;
5789	}
5790
5791	OP *
5792	Perl_ck_sassign(pTHX_ OP *o)
5793	{
5794	OP *kid = cLISTOPo->op_first;
5795	/* has a disposable target? */
5796	if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5797	&& !(kid->op_flags & OPf_STACKED)
5798	/* Cannot steal the second time! */
5799	&& !(kid->op_private & OPpTARGET_MY))
5800	{
5801	OP *kkid = kid->op_sibling;
5802
5803	/* Can just relocate the target. */
5804	if (kkid && kkid->op_type == OP_PADSV
5805	&& !(kkid->op_private & OPpLVAL_INTRO))
5806	{
5807	kid->op_targ = kkid->op_targ;
5808	kkid->op_targ = 0;
5809	/* Now we do not need PADSV and SASSIGN. */
5810	kid->op_sibling = o->op_sibling; /* NULL */
5811	cLISTOPo->op_first = NULL;
5812	op_free(o);
5813	op_free(kkid);
5814	kid->op_private \|= OPpTARGET_MY; /* Used for context settings */
5815	return kid;
5816	}
5817	}
5818	return o;
5819	}
5820
5821	OP *
5822	Perl_ck_scmp(pTHX_ OP *o)
5823	{
5824	o->op_private = 0;
5825	#ifdef USE_LOCALE
5826	if (PL_hints & HINT_LOCALE)
5827	o->op_private \|= OPpLOCALE;
5828	#endif
5829
5830	return o;
5831	}
5832
5833	OP *
5834	Perl_ck_match(pTHX_ OP *o)
5835	{
5836	o->op_private \|= OPpRUNTIME;
5837	return o;
5838	}
5839
5840	OP *
5841	Perl_ck_method(pTHX_ OP *o)
5842	{
5843	OP *kid = cUNOPo->op_first;
5844	if (kid->op_type == OP_CONST) {
5845	SV* sv = kSVOP->op_sv;
5846	if (!(strchr(SvPVX(sv), ':') \|\| strchr(SvPVX(sv), '\''))) {
5847	OP *cmop;
5848	(void)SvUPGRADE(sv, SVt_PVIV);
5849	(void)SvIOK_on(sv);
5850	PERL_HASH(SvUVX(sv), SvPVX(sv), SvCUR(sv));
5851	cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5852	kSVOP->op_sv = Nullsv;
5853	op_free(o);
5854	return cmop;
5855	}
5856	}
5857	return o;
5858	}
5859
5860	OP *
5861	Perl_ck_null(pTHX_ OP *o)
5862	{
5863	return o;
5864	}
5865
5866	OP *
5867	Perl_ck_open(pTHX_ OP *o)
5868	{
5869	HV *table = GvHV(PL_hintgv);
5870	if (table) {
5871	SV **svp;
5872	I32 mode;
5873	svp = hv_fetch(table, "open_IN", 7, FALSE);
5874	if (svp && *svp) {
5875	mode = mode_from_discipline(*svp);
5876	if (mode & O_BINARY)
5877	o->op_private \|= OPpOPEN_IN_RAW;
5878	else if (mode & O_TEXT)
5879	o->op_private \|= OPpOPEN_IN_CRLF;
5880	}
5881
5882	svp = hv_fetch(table, "open_OUT", 8, FALSE);
5883	if (svp && *svp) {
5884	mode = mode_from_discipline(*svp);
5885	if (mode & O_BINARY)
5886	o->op_private \|= OPpOPEN_OUT_RAW;
5887	else if (mode & O_TEXT)
5888	o->op_private \|= OPpOPEN_OUT_CRLF;
5889	}
5890	}
5891	if (o->op_type == OP_BACKTICK)
5892	return o;
5893	return ck_fun(o);
5894	}
5895
5896	OP *
5897	Perl_ck_repeat(pTHX_ OP *o)
5898	{
5899	if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5900	o->op_private \|= OPpREPEAT_DOLIST;
5901	cBINOPo->op_first = force_list(cBINOPo->op_first);
5902	}
5903	else
5904	scalar(o);
5905	return o;
5906	}
5907
5908	OP *
5909	Perl_ck_require(pTHX_ OP *o)
5910	{
5911	if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5912	SVOP kid = (SVOP)cUNOPo->op_first;
5913
5914	if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5915	char *s;
5916	for (s = SvPVX(kid->op_sv); *s; s++) {
5917	if (*s == ':' && s[1] == ':') {
5918	*s = '/';
5919	Move(s+2, s+1, strlen(s+2)+1, char);
5920	--SvCUR(kid->op_sv);
5921	}
5922	}
5923	if (SvREADONLY(kid->op_sv)) {
5924	SvREADONLY_off(kid->op_sv);
5925	sv_catpvn(kid->op_sv, ".pm", 3);
5926	SvREADONLY_on(kid->op_sv);
5927	}
5928	else
5929	sv_catpvn(kid->op_sv, ".pm", 3);
5930	}
5931	}
5932	return ck_fun(o);
5933	}
5934
5935	#if 0
5936	OP *
5937	Perl_ck_retarget(pTHX_ OP *o)
5938	{
5939	Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5940	/* STUB */
5941	return o;
5942	}
5943	#endif
5944
5945	OP *
5946	Perl_ck_select(pTHX_ OP *o)
5947	{
5948	OP* kid;
5949	if (o->op_flags & OPf_KIDS) {
5950	kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5951	if (kid && kid->op_sibling) {
5952	o->op_type = OP_SSELECT;
5953	o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5954	o = ck_fun(o);
5955	return fold_constants(o);
5956	}
5957	}
5958	o = ck_fun(o);
5959	kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5960	if (kid && kid->op_type == OP_RV2GV)
5961	kid->op_private &= ~HINT_STRICT_REFS;
5962	return o;
5963	}
5964
5965	OP *
5966	Perl_ck_shift(pTHX_ OP *o)
5967	{
5968	I32 type = o->op_type;
5969
5970	if (!(o->op_flags & OPf_KIDS)) {
5971	OP *argop;
5972
5973	op_free(o);
5974	#ifdef USE_THREADS
5975	if (!CvUNIQUE(PL_compcv)) {
5976	argop = newOP(OP_PADAV, OPf_REF);
5977	argop->op_targ = 0; /* PL_curpad[0] is @_ */
5978	}
5979	else {
5980	argop = newUNOP(OP_RV2AV, 0,
5981	scalar(newGVOP(OP_GV, 0,
5982	gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5983	}
5984	#else
5985	argop = newUNOP(OP_RV2AV, 0,
5986	scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
5987	PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5988	#endif /* USE_THREADS */
5989	return newUNOP(type, 0, scalar(argop));
5990	}
5991	return scalar(modkids(ck_fun(o), type));
5992	}
5993
5994	OP *
5995	Perl_ck_sort(pTHX_ OP *o)
5996	{
5997	o->op_private = 0;
5998	#ifdef USE_LOCALE
5999	if (PL_hints & HINT_LOCALE)
6000	o->op_private \|= OPpLOCALE;
6001	#endif
6002
6003	if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6004	simplify_sort(o);
6005	if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6006	OP kid = cLISTOPo->op_first->op_sibling; / get past pushmark */
6007	OP *k;
6008	kid = kUNOP->op_first; /* get past null */
6009
6010	if (kid->op_type == OP_SCOPE \|\| kid->op_type == OP_LEAVE) {
6011	linklist(kid);
6012	if (kid->op_type == OP_SCOPE) {
6013	k = kid->op_next;
6014	kid->op_next = 0;
6015	}
6016	else if (kid->op_type == OP_LEAVE) {
6017	if (o->op_type == OP_SORT) {
6018	null(kid); /* wipe out leave */
6019	kid->op_next = kid;
6020
6021	for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6022	if (k->op_next == kid)
6023	k->op_next = 0;
6024	/* don't descend into loops */
6025	else if (k->op_type == OP_ENTERLOOP
6026	\|\| k->op_type == OP_ENTERITER)
6027	{
6028	k = cLOOPx(k)->op_lastop;
6029	}
6030	}
6031	}
6032	else
6033	kid->op_next = 0; /* just disconnect the leave */
6034	k = kLISTOP->op_first;
6035	}
6036	peep(k);
6037
6038	kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6039	if (o->op_type == OP_SORT)
6040	kid->op_next = kid;
6041	else
6042	kid->op_next = k;
6043	o->op_flags \|= OPf_SPECIAL;
6044	}
6045	else if (kid->op_type == OP_RV2SV \|\| kid->op_type == OP_PADSV)
6046	null(cLISTOPo->op_first->op_sibling);
6047	}
6048
6049	return o;
6050	}
6051
6052	STATIC void
6053	S_simplify_sort(pTHX_ OP *o)
6054	{
6055	dTHR;
6056	register OP kid = cLISTOPo->op_first->op_sibling; / get past pushmark */
6057	OP *k;
6058	int reversed;
6059	GV *gv;
6060	if (!(o->op_flags & OPf_STACKED))
6061	return;
6062	GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6063	GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6064	kid = kUNOP->op_first; /* get past null */
6065	if (kid->op_type != OP_SCOPE)
6066	return;
6067	kid = kLISTOP->op_last; /* get past scope */
6068	switch(kid->op_type) {
6069	case OP_NCMP:
6070	case OP_I_NCMP:
6071	case OP_SCMP:
6072	break;
6073	default:
6074	return;
6075	}
6076	k = kid; /* remember this node*/
6077	if (kBINOP->op_first->op_type != OP_RV2SV)
6078	return;
6079	kid = kBINOP->op_first; /* get past cmp */
6080	if (kUNOP->op_first->op_type != OP_GV)
6081	return;
6082	kid = kUNOP->op_first; /* get past rv2sv */
6083	gv = kGVOP_gv;
6084	if (GvSTASH(gv) != PL_curstash)
6085	return;
6086	if (strEQ(GvNAME(gv), "a"))
6087	reversed = 0;
6088	else if (strEQ(GvNAME(gv), "b"))
6089	reversed = 1;
6090	else
6091	return;
6092	kid = k; /* back to cmp */
6093	if (kBINOP->op_last->op_type != OP_RV2SV)
6094	return;
6095	kid = kBINOP->op_last; /* down to 2nd arg */
6096	if (kUNOP->op_first->op_type != OP_GV)
6097	return;
6098	kid = kUNOP->op_first; /* get past rv2sv */
6099	gv = kGVOP_gv;
6100	if (GvSTASH(gv) != PL_curstash
6101	\|\| ( reversed
6102	? strNE(GvNAME(gv), "a")
6103	: strNE(GvNAME(gv), "b")))
6104	return;
6105	o->op_flags &= ~(OPf_STACKED \| OPf_SPECIAL);
6106	if (reversed)
6107	o->op_private \|= OPpSORT_REVERSE;
6108	if (k->op_type == OP_NCMP)
6109	o->op_private \|= OPpSORT_NUMERIC;
6110	if (k->op_type == OP_I_NCMP)
6111	o->op_private \|= OPpSORT_NUMERIC \| OPpSORT_INTEGER;
6112	kid = cLISTOPo->op_first->op_sibling;
6113	cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6114	op_free(kid); /* then delete it */
6115	cLISTOPo->op_children--;
6116	}
6117
6118	OP *
6119	Perl_ck_split(pTHX_ OP *o)
6120	{
6121	register OP *kid;
6122
6123	if (o->op_flags & OPf_STACKED)
6124	return no_fh_allowed(o);
6125
6126	kid = cLISTOPo->op_first;
6127	if (kid->op_type != OP_NULL)
6128	Perl_croak(aTHX_ "panic: ck_split");
6129	kid = kid->op_sibling;
6130	op_free(cLISTOPo->op_first);
6131	cLISTOPo->op_first = kid;
6132	if (!kid) {
6133	cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6134	cLISTOPo->op_last = kid; /* There was only one element previously */
6135	}
6136
6137	if (kid->op_type != OP_MATCH) {
6138	OP *sibl = kid->op_sibling;
6139	kid->op_sibling = 0;
6140	kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6141	if (cLISTOPo->op_first == cLISTOPo->op_last)
6142	cLISTOPo->op_last = kid;
6143	cLISTOPo->op_first = kid;
6144	kid->op_sibling = sibl;
6145	}
6146
6147	kid->op_type = OP_PUSHRE;
6148	kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6149	scalar(kid);
6150
6151	if (!kid->op_sibling)
6152	append_elem(OP_SPLIT, o, newDEFSVOP());
6153
6154	kid = kid->op_sibling;
6155	scalar(kid);
6156
6157	if (!kid->op_sibling)
6158	append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6159
6160	kid = kid->op_sibling;
6161	scalar(kid);
6162
6163	if (kid->op_sibling)
6164	return too_many_arguments(o,PL_op_desc[o->op_type]);
6165
6166	return o;
6167	}
6168
6169	OP *
6170	Perl_ck_join(pTHX_ OP *o)
6171	{
6172	if (ckWARN(WARN_SYNTAX)) {
6173	OP *kid = cLISTOPo->op_first->op_sibling;
6174	if (kid && kid->op_type == OP_MATCH) {
6175	char *pmstr = "STRING";
6176	if (kPMOP->op_pmregexp)
6177	pmstr = kPMOP->op_pmregexp->precomp;
6178	Perl_warner(aTHX_ WARN_SYNTAX,
6179	"/%s/ should probably be written as \"%s\"",
6180	pmstr, pmstr);
6181	}
6182	}
6183	return ck_fun(o);
6184	}
6185
6186	OP *
6187	Perl_ck_subr(pTHX_ OP *o)
6188	{
6189	dTHR;
6190	OP *prev = ((cUNOPo->op_first->op_sibling)
6191	? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6192	OP *o2 = prev->op_sibling;
6193	OP *cvop;
6194	char *proto = 0;
6195	CV *cv = 0;
6196	GV *namegv = 0;
6197	int optional = 0;
6198	I32 arg = 0;
6199	STRLEN n_a;
6200
6201	o->op_private \|= OPpENTERSUB_HASTARG;
6202	for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6203	if (cvop->op_type == OP_RV2CV) {
6204	SVOP* tmpop;
6205	o->op_private \|= (cvop->op_private & OPpENTERSUB_AMPER);
6206	null(cvop); /* disable rv2cv */
6207	tmpop = (SVOP)((UNOP)cvop)->op_first;
6208	if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6209	GV *gv = cGVOPx_gv(tmpop);
6210	cv = GvCVu(gv);
6211	if (!cv)
6212	tmpop->op_private \|= OPpEARLY_CV;
6213	else if (SvPOK(cv)) {
6214	namegv = CvANON(cv) ? gv : CvGV(cv);
6215	proto = SvPV((SV*)cv, n_a);
6216	}
6217	}
6218	}
6219	else if (cvop->op_type == OP_METHOD \|\| cvop->op_type == OP_METHOD_NAMED) {
6220	if (o2->op_type == OP_CONST)
6221	o2->op_private &= ~OPpCONST_STRICT;
6222	else if (o2->op_type == OP_LIST) {
6223	OP o = ((UNOP)o2)->op_first->op_sibling;
6224	if (o && o->op_type == OP_CONST)
6225	o->op_private &= ~OPpCONST_STRICT;
6226	}
6227	}
6228	o->op_private \|= (PL_hints & HINT_STRICT_REFS);
6229	if (PERLDB_SUB && PL_curstash != PL_debstash)
6230	o->op_private \|= OPpENTERSUB_DB;
6231	while (o2 != cvop) {
6232	if (proto) {
6233	switch (*proto) {
6234	case '\0':
6235	return too_many_arguments(o, gv_ename(namegv));
6236	case ';':
6237	optional = 1;
6238	proto++;
6239	continue;
6240	case '$':
6241	proto++;
6242	arg++;
6243	scalar(o2);
6244	break;
6245	case '%':
6246	case '@':
6247	list(o2);
6248	arg++;
6249	break;
6250	case '&':
6251	proto++;
6252	arg++;
6253	if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6254	bad_type(arg, "block", gv_ename(namegv), o2);
6255	break;
6256	case '*':
6257	/* '' allows any scalar type, including bareword /
6258	proto++;
6259	arg++;
6260	if (o2->op_type == OP_RV2GV)
6261	goto wrapref; /* autoconvert GLOB -> GLOBref */
6262	else if (o2->op_type == OP_CONST)
6263	o2->op_private &= ~OPpCONST_STRICT;
6264	else if (o2->op_type == OP_ENTERSUB) {
6265	/* accidental subroutine, revert to bareword */
6266	OP gvop = ((UNOP)o2)->op_first;
6267	if (gvop && gvop->op_type == OP_NULL) {
6268	gvop = ((UNOP*)gvop)->op_first;
6269	if (gvop) {
6270	for (; gvop->op_sibling; gvop = gvop->op_sibling)
6271	;
6272	if (gvop &&
6273	(gvop->op_private & OPpENTERSUB_NOPAREN) &&
6274	(gvop = ((UNOP*)gvop)->op_first) &&
6275	gvop->op_type == OP_GV)
6276	{
6277	GV *gv = cGVOPx_gv(gvop);
6278	OP *sibling = o2->op_sibling;
6279	SV *n = newSVpvn("",0);
6280	op_free(o2);
6281	gv_fullname3(n, gv, "");
6282	if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6283	sv_chop(n, SvPVX(n)+6);
6284	o2 = newSVOP(OP_CONST, 0, n);
6285	prev->op_sibling = o2;
6286	o2->op_sibling = sibling;
6287	}
6288	}
6289	}
6290	}
6291	scalar(o2);
6292	break;
6293	case '\\':
6294	proto++;
6295	arg++;
6296	switch (*proto++) {
6297	case '*':
6298	if (o2->op_type != OP_RV2GV)
6299	bad_type(arg, "symbol", gv_ename(namegv), o2);
6300	goto wrapref;
6301	case '&':
6302	if (o2->op_type != OP_RV2CV)
6303	bad_type(arg, "sub", gv_ename(namegv), o2);
6304	goto wrapref;
6305	case '$':
6306	if (o2->op_type != OP_RV2SV
6307	&& o2->op_type != OP_PADSV
6308	&& o2->op_type != OP_HELEM
6309	&& o2->op_type != OP_AELEM
6310	&& o2->op_type != OP_THREADSV)
6311	{
6312	bad_type(arg, "scalar", gv_ename(namegv), o2);
6313	}
6314	goto wrapref;
6315	case '@':
6316	if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6317	bad_type(arg, "array", gv_ename(namegv), o2);
6318	goto wrapref;
6319	case '%':
6320	if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6321	bad_type(arg, "hash", gv_ename(namegv), o2);
6322	wrapref:
6323	{
6324	OP* kid = o2;
6325	OP* sib = kid->op_sibling;
6326	kid->op_sibling = 0;
6327	o2 = newUNOP(OP_REFGEN, 0, kid);
6328	o2->op_sibling = sib;
6329	prev->op_sibling = o2;
6330	}
6331	break;
6332	default: goto oops;
6333	}
6334	break;
6335	case ' ':
6336	proto++;
6337	continue;
6338	default:
6339	oops:
6340	Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6341	gv_ename(namegv), SvPV((SV*)cv, n_a));
6342	}
6343	}
6344	else
6345	list(o2);
6346	mod(o2, OP_ENTERSUB);
6347	prev = o2;
6348	o2 = o2->op_sibling;
6349	}
6350	if (proto && !optional &&
6351	(proto && proto != '@' && proto != '%' && proto != ';'))
6352	return too_few_arguments(o, gv_ename(namegv));
6353	return o;
6354	}
6355
6356	OP *
6357	Perl_ck_svconst(pTHX_ OP *o)
6358	{
6359	SvREADONLY_on(cSVOPo->op_sv);
6360	return o;
6361	}
6362
6363	OP *
6364	Perl_ck_trunc(pTHX_ OP *o)
6365	{
6366	if (o->op_flags & OPf_KIDS) {
6367	SVOP kid = (SVOP)cUNOPo->op_first;
6368
6369	if (kid->op_type == OP_NULL)
6370	kid = (SVOP*)kid->op_sibling;
6371	if (kid && kid->op_type == OP_CONST &&
6372	(kid->op_private & OPpCONST_BARE))
6373	{
6374	o->op_flags \|= OPf_SPECIAL;
6375	kid->op_private &= ~OPpCONST_STRICT;
6376	}
6377	}
6378	return ck_fun(o);
6379	}
6380
6381	/* A peephole optimizer. We visit the ops in the order they're to execute. */
6382
6383	void
6384	Perl_peep(pTHX_ register OP *o)
6385	{
6386	dTHR;
6387	register OP* oldop = 0;
6388	STRLEN n_a;
6389	OP *last_composite = Nullop;
6390
6391	if (!o \|\| o->op_seq)
6392	return;
6393	ENTER;
6394	SAVEOP();
6395	SAVEVPTR(PL_curcop);
6396	for (; o; o = o->op_next) {
6397	if (o->op_seq)
6398	break;
6399	if (!PL_op_seqmax)
6400	PL_op_seqmax++;
6401	PL_op = o;
6402	switch (o->op_type) {
6403	case OP_SETSTATE:
6404	case OP_NEXTSTATE:
6405	case OP_DBSTATE:
6406	PL_curcop = ((COP)o); / for warnings */
6407	o->op_seq = PL_op_seqmax++;
6408	last_composite = Nullop;
6409	break;
6410
6411	case OP_CONST:
6412	if (cSVOPo->op_private & OPpCONST_STRICT)
6413	no_bareword_allowed(o);
6414	#ifdef USE_ITHREADS
6415	/* Relocate sv to the pad for thread safety.
6416	* Despite being a "constant", the SV is written to,
6417	* for reference counts, sv_upgrade() etc. */
6418	if (cSVOP->op_sv) {
6419	PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6420	SvREFCNT_dec(PL_curpad[ix]);
6421	SvPADTMP_on(cSVOPo->op_sv);
6422	PL_curpad[ix] = cSVOPo->op_sv;
6423	cSVOPo->op_sv = Nullsv;
6424	o->op_targ = ix;
6425	}
6426	#endif
6427	o->op_seq = PL_op_seqmax++;
6428	break;
6429
6430	case OP_CONCAT:
6431	if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6432	if (o->op_next->op_private & OPpTARGET_MY) {
6433	if (o->op_flags & OPf_STACKED) /* chained concats */
6434	goto ignore_optimization;
6435	else {
6436	/* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6437	o->op_targ = o->op_next->op_targ;
6438	o->op_next->op_targ = 0;
6439	o->op_private \|= OPpTARGET_MY;
6440	}
6441	}
6442	null(o->op_next);
6443	}
6444	ignore_optimization:
6445	o->op_seq = PL_op_seqmax++;
6446	break;
6447	case OP_STUB:
6448	if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6449	o->op_seq = PL_op_seqmax++;
6450	break; /* Scalar stub must produce undef. List stub is noop */
6451	}
6452	goto nothin;
6453	case OP_NULL:
6454	if (o->op_targ == OP_NEXTSTATE
6455	\|\| o->op_targ == OP_DBSTATE
6456	\|\| o->op_targ == OP_SETSTATE)
6457	{
6458	PL_curcop = ((COP*)o);
6459	}
6460	goto nothin;
6461	case OP_SCALAR:
6462	case OP_LINESEQ:
6463	case OP_SCOPE:
6464	nothin:
6465	if (oldop && o->op_next) {
6466	oldop->op_next = o->op_next;
6467	continue;
6468	}
6469	o->op_seq = PL_op_seqmax++;
6470	break;
6471
6472	case OP_GV:
6473	if (o->op_next->op_type == OP_RV2SV) {
6474	if (!(o->op_next->op_private & OPpDEREF)) {
6475	null(o->op_next);
6476	o->op_private \|= o->op_next->op_private & (OPpLVAL_INTRO
6477	\| OPpOUR_INTRO);
6478	o->op_next = o->op_next->op_next;
6479	o->op_type = OP_GVSV;
6480	o->op_ppaddr = PL_ppaddr[OP_GVSV];
6481	}
6482	}
6483	else if (o->op_next->op_type == OP_RV2AV) {
6484	OP* pop = o->op_next->op_next;
6485	IV i;
6486	if (pop->op_type == OP_CONST &&
6487	(PL_op = pop->op_next) &&
6488	pop->op_next->op_type == OP_AELEM &&
6489	!(pop->op_next->op_private &
6490	(OPpLVAL_INTRO\|OPpLVAL_DEFER\|OPpDEREF)) &&
6491	(i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6492	<= 255 &&
6493	i >= 0)
6494	{
6495	GV *gv;
6496	null(o->op_next);
6497	null(pop->op_next);
6498	null(pop);
6499	o->op_flags \|= pop->op_next->op_flags & OPf_MOD;
6500	o->op_next = pop->op_next->op_next;
6501	o->op_type = OP_AELEMFAST;
6502	o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6503	o->op_private = (U8)i;
6504	gv = cGVOPo_gv;
6505	GvAVn(gv);
6506	}
6507	}
6508	else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6509	GV *gv = cGVOPo_gv;
6510	if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6511	/* XXX could check prototype here instead of just carping */
6512	SV *sv = sv_newmortal();
6513	gv_efullname3(sv, gv, Nullch);
6514	Perl_warner(aTHX_ WARN_PROTOTYPE,
6515	"%s() called too early to check prototype",
6516	SvPV_nolen(sv));
6517	}
6518	}
6519
6520	o->op_seq = PL_op_seqmax++;
6521	break;
6522
6523	case OP_MAPWHILE:
6524	case OP_GREPWHILE:
6525	case OP_AND:
6526	case OP_OR:
6527	case OP_ANDASSIGN:
6528	case OP_ORASSIGN:
6529	case OP_COND_EXPR:
6530	case OP_RANGE:
6531	o->op_seq = PL_op_seqmax++;
6532	while (cLOGOP->op_other->op_type == OP_NULL)
6533	cLOGOP->op_other = cLOGOP->op_other->op_next;
6534	peep(cLOGOP->op_other);
6535	break;
6536
6537	case OP_ENTERLOOP:
6538	o->op_seq = PL_op_seqmax++;
6539	peep(cLOOP->op_redoop);
6540	peep(cLOOP->op_nextop);
6541	peep(cLOOP->op_lastop);
6542	break;
6543
6544	case OP_QR:
6545	case OP_MATCH:
6546	case OP_SUBST:
6547	o->op_seq = PL_op_seqmax++;
6548	peep(cPMOP->op_pmreplstart);
6549	break;
6550
6551	case OP_EXEC:
6552	o->op_seq = PL_op_seqmax++;
6553	if (ckWARN(WARN_SYNTAX) && o->op_next
6554	&& o->op_next->op_type == OP_NEXTSTATE) {
6555	if (o->op_next->op_sibling &&
6556	o->op_next->op_sibling->op_type != OP_EXIT &&
6557	o->op_next->op_sibling->op_type != OP_WARN &&
6558	o->op_next->op_sibling->op_type != OP_DIE) {
6559	line_t oldline = CopLINE(PL_curcop);
6560
6561	CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6562	Perl_warner(aTHX_ WARN_EXEC,
6563	"Statement unlikely to be reached");
6564	Perl_warner(aTHX_ WARN_EXEC,
6565	"\t(Maybe you meant system() when you said exec()?)\n");
6566	CopLINE_set(PL_curcop, oldline);
6567	}
6568	}
6569	break;
6570
6571	case OP_HELEM: {
6572	UNOP *rop;
6573	SV *lexname;
6574	GV **fields;
6575	SV svp, indsvp, *sv;
6576	I32 ind;
6577	char *key;
6578	STRLEN keylen;
6579
6580	o->op_seq = PL_op_seqmax++;
6581	if ((o->op_private & (OPpLVAL_INTRO))
6582	\|\| ((BINOP*)o)->op_last->op_type != OP_CONST)
6583	break;
6584	rop = (UNOP)((BINOP)o)->op_first;
6585	if (rop->op_type != OP_RV2HV \|\| rop->op_first->op_type != OP_PADSV)
6586	break;
6587	lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6588	if (!SvOBJECT(lexname))
6589	break;
6590	fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6591	if (!fields \|\| !GvHV(*fields))
6592	break;
6593	svp = cSVOPx_svp(((BINOP*)o)->op_last);
6594	key = SvPV(*svp, keylen);
6595	indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6596	if (!indsvp) {
6597	Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6598	key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6599	}
6600	ind = SvIV(*indsvp);
6601	if (ind < 1)
6602	Perl_croak(aTHX_ "Bad index while coercing array into hash");
6603	rop->op_type = OP_RV2AV;
6604	rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6605	o->op_type = OP_AELEM;
6606	o->op_ppaddr = PL_ppaddr[OP_AELEM];
6607	sv = newSViv(ind);
6608	if (SvREADONLY(*svp))
6609	SvREADONLY_on(sv);
6610	SvFLAGS(sv) \|= (SvFLAGS(*svp)
6611	& (SVs_PADBUSY\|SVs_PADTMP\|SVs_PADMY));
6612	SvREFCNT_dec(*svp);
6613	*svp = sv;
6614	break;
6615	}
6616
6617	case OP_HSLICE: {
6618	UNOP *rop;
6619	SV *lexname;
6620	GV **fields;
6621	SV svp, indsvp, *sv;
6622	I32 ind;
6623	char *key;
6624	STRLEN keylen;
6625	SVOP first_key_op, key_op;
6626
6627	o->op_seq = PL_op_seqmax++;
6628	if ((o->op_private & (OPpLVAL_INTRO))
6629	/* I bet there's always a pushmark... */
6630	\|\| ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6631	/* hmmm, no optimization if list contains only one key. */
6632	break;
6633	rop = (UNOP)((LISTOP)o)->op_last;
6634	if (rop->op_type != OP_RV2HV \|\| rop->op_first->op_type != OP_PADSV)
6635	break;
6636	lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6637	if (!SvOBJECT(lexname))
6638	break;
6639	fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6640	if (!fields \|\| !GvHV(*fields))
6641	break;
6642	/* Again guessing that the pushmark can be jumped over.... */
6643	first_key_op = (SVOP)((LISTOP)((LISTOP*)o)->op_first->op_sibling)
6644	->op_first->op_sibling;
6645	/* Check that the key list contains only constants. */
6646	for (key_op = first_key_op; key_op;
6647	key_op = (SVOP*)key_op->op_sibling)
6648	if (key_op->op_type != OP_CONST)
6649	break;
6650	if (key_op)
6651	break;
6652	rop->op_type = OP_RV2AV;
6653	rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6654	o->op_type = OP_ASLICE;
6655	o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6656	for (key_op = first_key_op; key_op;
6657	key_op = (SVOP*)key_op->op_sibling) {
6658	svp = cSVOPx_svp(key_op);
6659	key = SvPV(*svp, keylen);
6660	indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6661	if (!indsvp) {
6662	Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6663	"in variable %s of type %s",
6664	key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6665	}
6666	ind = SvIV(*indsvp);
6667	if (ind < 1)
6668	Perl_croak(aTHX_ "Bad index while coercing array into hash");
6669	sv = newSViv(ind);
6670	if (SvREADONLY(*svp))
6671	SvREADONLY_on(sv);
6672	SvFLAGS(sv) \|= (SvFLAGS(*svp)
6673	& (SVs_PADBUSY\|SVs_PADTMP\|SVs_PADMY));
6674	SvREFCNT_dec(*svp);
6675	*svp = sv;
6676	}
6677	break;
6678	}
6679
6680	case OP_RV2AV:
6681	case OP_RV2HV:
6682	if (!(o->op_flags & OPf_WANT)
6683	\|\| (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
6684	{
6685	last_composite = o;
6686	}
6687	o->op_seq = PL_op_seqmax++;
6688	break;
6689
6690	case OP_RETURN:
6691	if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
6692	o->op_seq = PL_op_seqmax++;
6693	break;
6694	}
6695	/* FALL THROUGH */
6696
6697	case OP_LEAVESUBLV:
6698	if (last_composite) {
6699	OP *r = last_composite;
6700
6701	while (r->op_sibling)
6702	r = r->op_sibling;
6703	if (r->op_next == o
6704	\|\| (r->op_next->op_type == OP_LIST
6705	&& r->op_next->op_next == o))
6706	{
6707	if (last_composite->op_type == OP_RV2AV)
6708	yyerror("Lvalue subs returning arrays not implemented yet");
6709	else
6710	yyerror("Lvalue subs returning hashes not implemented yet");
6711	;
6712	}
6713	}
6714	/* FALL THROUGH */
6715
6716	default:
6717	o->op_seq = PL_op_seqmax++;
6718	break;
6719	}
6720	oldop = o;
6721	}
6722	LEAVE;
6723	}

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

Download in other formats: