Context Navigation

op.c @ 20075

Visit:

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

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

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

Context Navigation

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

Download in other formats: