1*0Sstevel@tonic-gate /* op.c
2*0Sstevel@tonic-gate *
3*0Sstevel@tonic-gate * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4*0Sstevel@tonic-gate * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
5*0Sstevel@tonic-gate *
6*0Sstevel@tonic-gate * You may distribute under the terms of either the GNU General Public
7*0Sstevel@tonic-gate * License or the Artistic License, as specified in the README file.
8*0Sstevel@tonic-gate *
9*0Sstevel@tonic-gate */
10*0Sstevel@tonic-gate
11*0Sstevel@tonic-gate /*
12*0Sstevel@tonic-gate * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13*0Sstevel@tonic-gate * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14*0Sstevel@tonic-gate * youngest of the Old Took's daughters); and Mr. Drogo was his second
15*0Sstevel@tonic-gate * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16*0Sstevel@tonic-gate * either way, as the saying is, if you follow me." --the Gaffer
17*0Sstevel@tonic-gate */
18*0Sstevel@tonic-gate
19*0Sstevel@tonic-gate
20*0Sstevel@tonic-gate #include "EXTERN.h"
21*0Sstevel@tonic-gate #define PERL_IN_OP_C
22*0Sstevel@tonic-gate #include "perl.h"
23*0Sstevel@tonic-gate #include "keywords.h"
24*0Sstevel@tonic-gate
25*0Sstevel@tonic-gate #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
26*0Sstevel@tonic-gate
27*0Sstevel@tonic-gate #if defined(PL_OP_SLAB_ALLOC)
28*0Sstevel@tonic-gate
29*0Sstevel@tonic-gate #ifndef PERL_SLAB_SIZE
30*0Sstevel@tonic-gate #define PERL_SLAB_SIZE 2048
31*0Sstevel@tonic-gate #endif
32*0Sstevel@tonic-gate
33*0Sstevel@tonic-gate void *
Perl_Slab_Alloc(pTHX_ int m,size_t sz)34*0Sstevel@tonic-gate Perl_Slab_Alloc(pTHX_ int m, size_t sz)
35*0Sstevel@tonic-gate {
36*0Sstevel@tonic-gate /*
37*0Sstevel@tonic-gate * To make incrementing use count easy PL_OpSlab is an I32 *
38*0Sstevel@tonic-gate * To make inserting the link to slab PL_OpPtr is I32 **
39*0Sstevel@tonic-gate * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
40*0Sstevel@tonic-gate * Add an overhead for pointer to slab and round up as a number of pointers
41*0Sstevel@tonic-gate */
42*0Sstevel@tonic-gate sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
43*0Sstevel@tonic-gate if ((PL_OpSpace -= sz) < 0) {
44*0Sstevel@tonic-gate PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
45*0Sstevel@tonic-gate if (!PL_OpPtr) {
46*0Sstevel@tonic-gate return NULL;
47*0Sstevel@tonic-gate }
48*0Sstevel@tonic-gate Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
49*0Sstevel@tonic-gate /* We reserve the 0'th I32 sized chunk as a use count */
50*0Sstevel@tonic-gate PL_OpSlab = (I32 *) PL_OpPtr;
51*0Sstevel@tonic-gate /* Reduce size by the use count word, and by the size we need.
52*0Sstevel@tonic-gate * Latter is to mimic the '-=' in the if() above
53*0Sstevel@tonic-gate */
54*0Sstevel@tonic-gate PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
55*0Sstevel@tonic-gate /* Allocation pointer starts at the top.
56*0Sstevel@tonic-gate Theory: because we build leaves before trunk allocating at end
57*0Sstevel@tonic-gate means that at run time access is cache friendly upward
58*0Sstevel@tonic-gate */
59*0Sstevel@tonic-gate PL_OpPtr += PERL_SLAB_SIZE;
60*0Sstevel@tonic-gate }
61*0Sstevel@tonic-gate assert( PL_OpSpace >= 0 );
62*0Sstevel@tonic-gate /* Move the allocation pointer down */
63*0Sstevel@tonic-gate PL_OpPtr -= sz;
64*0Sstevel@tonic-gate assert( PL_OpPtr > (I32 **) PL_OpSlab );
65*0Sstevel@tonic-gate *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
66*0Sstevel@tonic-gate (*PL_OpSlab)++; /* Increment use count of slab */
67*0Sstevel@tonic-gate assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
68*0Sstevel@tonic-gate assert( *PL_OpSlab > 0 );
69*0Sstevel@tonic-gate return (void *)(PL_OpPtr + 1);
70*0Sstevel@tonic-gate }
71*0Sstevel@tonic-gate
72*0Sstevel@tonic-gate void
Perl_Slab_Free(pTHX_ void * op)73*0Sstevel@tonic-gate Perl_Slab_Free(pTHX_ void *op)
74*0Sstevel@tonic-gate {
75*0Sstevel@tonic-gate I32 **ptr = (I32 **) op;
76*0Sstevel@tonic-gate I32 *slab = ptr[-1];
77*0Sstevel@tonic-gate assert( ptr-1 > (I32 **) slab );
78*0Sstevel@tonic-gate assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
79*0Sstevel@tonic-gate assert( *slab > 0 );
80*0Sstevel@tonic-gate if (--(*slab) == 0) {
81*0Sstevel@tonic-gate # ifdef NETWARE
82*0Sstevel@tonic-gate # define PerlMemShared PerlMem
83*0Sstevel@tonic-gate # endif
84*0Sstevel@tonic-gate
85*0Sstevel@tonic-gate PerlMemShared_free(slab);
86*0Sstevel@tonic-gate if (slab == PL_OpSlab) {
87*0Sstevel@tonic-gate PL_OpSpace = 0;
88*0Sstevel@tonic-gate }
89*0Sstevel@tonic-gate }
90*0Sstevel@tonic-gate }
91*0Sstevel@tonic-gate #endif
92*0Sstevel@tonic-gate /*
93*0Sstevel@tonic-gate * In the following definition, the ", Nullop" is just to make the compiler
94*0Sstevel@tonic-gate * think the expression is of the right type: croak actually does a Siglongjmp.
95*0Sstevel@tonic-gate */
96*0Sstevel@tonic-gate #define CHECKOP(type,o) \
97*0Sstevel@tonic-gate ((PL_op_mask && PL_op_mask[type]) \
98*0Sstevel@tonic-gate ? ( op_free((OP*)o), \
99*0Sstevel@tonic-gate Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
100*0Sstevel@tonic-gate Nullop ) \
101*0Sstevel@tonic-gate : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
102*0Sstevel@tonic-gate
103*0Sstevel@tonic-gate #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
104*0Sstevel@tonic-gate
105*0Sstevel@tonic-gate STATIC char*
S_gv_ename(pTHX_ GV * gv)106*0Sstevel@tonic-gate S_gv_ename(pTHX_ GV *gv)
107*0Sstevel@tonic-gate {
108*0Sstevel@tonic-gate STRLEN n_a;
109*0Sstevel@tonic-gate SV* tmpsv = sv_newmortal();
110*0Sstevel@tonic-gate gv_efullname3(tmpsv, gv, Nullch);
111*0Sstevel@tonic-gate return SvPV(tmpsv,n_a);
112*0Sstevel@tonic-gate }
113*0Sstevel@tonic-gate
114*0Sstevel@tonic-gate STATIC OP *
S_no_fh_allowed(pTHX_ OP * o)115*0Sstevel@tonic-gate S_no_fh_allowed(pTHX_ OP *o)
116*0Sstevel@tonic-gate {
117*0Sstevel@tonic-gate yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
118*0Sstevel@tonic-gate OP_DESC(o)));
119*0Sstevel@tonic-gate return o;
120*0Sstevel@tonic-gate }
121*0Sstevel@tonic-gate
122*0Sstevel@tonic-gate STATIC OP *
S_too_few_arguments(pTHX_ OP * o,char * name)123*0Sstevel@tonic-gate S_too_few_arguments(pTHX_ OP *o, char *name)
124*0Sstevel@tonic-gate {
125*0Sstevel@tonic-gate yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
126*0Sstevel@tonic-gate return o;
127*0Sstevel@tonic-gate }
128*0Sstevel@tonic-gate
129*0Sstevel@tonic-gate STATIC OP *
S_too_many_arguments(pTHX_ OP * o,char * name)130*0Sstevel@tonic-gate S_too_many_arguments(pTHX_ OP *o, char *name)
131*0Sstevel@tonic-gate {
132*0Sstevel@tonic-gate yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
133*0Sstevel@tonic-gate return o;
134*0Sstevel@tonic-gate }
135*0Sstevel@tonic-gate
136*0Sstevel@tonic-gate STATIC void
S_bad_type(pTHX_ I32 n,char * t,char * name,OP * kid)137*0Sstevel@tonic-gate S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
138*0Sstevel@tonic-gate {
139*0Sstevel@tonic-gate yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
140*0Sstevel@tonic-gate (int)n, name, t, OP_DESC(kid)));
141*0Sstevel@tonic-gate }
142*0Sstevel@tonic-gate
143*0Sstevel@tonic-gate STATIC void
S_no_bareword_allowed(pTHX_ OP * o)144*0Sstevel@tonic-gate S_no_bareword_allowed(pTHX_ OP *o)
145*0Sstevel@tonic-gate {
146*0Sstevel@tonic-gate qerror(Perl_mess(aTHX_
147*0Sstevel@tonic-gate "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
148*0Sstevel@tonic-gate cSVOPo_sv));
149*0Sstevel@tonic-gate }
150*0Sstevel@tonic-gate
151*0Sstevel@tonic-gate /* "register" allocation */
152*0Sstevel@tonic-gate
153*0Sstevel@tonic-gate PADOFFSET
Perl_allocmy(pTHX_ char * name)154*0Sstevel@tonic-gate Perl_allocmy(pTHX_ char *name)
155*0Sstevel@tonic-gate {
156*0Sstevel@tonic-gate PADOFFSET off;
157*0Sstevel@tonic-gate
158*0Sstevel@tonic-gate /* complain about "my $_" etc etc */
159*0Sstevel@tonic-gate if (!(PL_in_my == KEY_our ||
160*0Sstevel@tonic-gate isALPHA(name[1]) ||
161*0Sstevel@tonic-gate (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
162*0Sstevel@tonic-gate (name[1] == '_' && (int)strlen(name) > 2)))
163*0Sstevel@tonic-gate {
164*0Sstevel@tonic-gate if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
165*0Sstevel@tonic-gate /* 1999-02-27 mjd@plover.com */
166*0Sstevel@tonic-gate char *p;
167*0Sstevel@tonic-gate p = strchr(name, '\0');
168*0Sstevel@tonic-gate /* The next block assumes the buffer is at least 205 chars
169*0Sstevel@tonic-gate long. At present, it's always at least 256 chars. */
170*0Sstevel@tonic-gate if (p-name > 200) {
171*0Sstevel@tonic-gate strcpy(name+200, "...");
172*0Sstevel@tonic-gate p = name+199;
173*0Sstevel@tonic-gate }
174*0Sstevel@tonic-gate else {
175*0Sstevel@tonic-gate p[1] = '\0';
176*0Sstevel@tonic-gate }
177*0Sstevel@tonic-gate /* Move everything else down one character */
178*0Sstevel@tonic-gate for (; p-name > 2; p--)
179*0Sstevel@tonic-gate *p = *(p-1);
180*0Sstevel@tonic-gate name[2] = toCTRL(name[1]);
181*0Sstevel@tonic-gate name[1] = '^';
182*0Sstevel@tonic-gate }
183*0Sstevel@tonic-gate yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
184*0Sstevel@tonic-gate }
185*0Sstevel@tonic-gate /* check for duplicate declaration */
186*0Sstevel@tonic-gate pad_check_dup(name,
187*0Sstevel@tonic-gate (bool)(PL_in_my == KEY_our),
188*0Sstevel@tonic-gate (PL_curstash ? PL_curstash : PL_defstash)
189*0Sstevel@tonic-gate );
190*0Sstevel@tonic-gate
191*0Sstevel@tonic-gate if (PL_in_my_stash && *name != '$') {
192*0Sstevel@tonic-gate yyerror(Perl_form(aTHX_
193*0Sstevel@tonic-gate "Can't declare class for non-scalar %s in \"%s\"",
194*0Sstevel@tonic-gate name, PL_in_my == KEY_our ? "our" : "my"));
195*0Sstevel@tonic-gate }
196*0Sstevel@tonic-gate
197*0Sstevel@tonic-gate /* allocate a spare slot and store the name in that slot */
198*0Sstevel@tonic-gate
199*0Sstevel@tonic-gate off = pad_add_name(name,
200*0Sstevel@tonic-gate PL_in_my_stash,
201*0Sstevel@tonic-gate (PL_in_my == KEY_our
202*0Sstevel@tonic-gate ? (PL_curstash ? PL_curstash : PL_defstash)
203*0Sstevel@tonic-gate : Nullhv
204*0Sstevel@tonic-gate ),
205*0Sstevel@tonic-gate 0 /* not fake */
206*0Sstevel@tonic-gate );
207*0Sstevel@tonic-gate return off;
208*0Sstevel@tonic-gate }
209*0Sstevel@tonic-gate
210*0Sstevel@tonic-gate
211*0Sstevel@tonic-gate #ifdef USE_5005THREADS
212*0Sstevel@tonic-gate /* find_threadsv is not reentrant */
213*0Sstevel@tonic-gate PADOFFSET
Perl_find_threadsv(pTHX_ const char * name)214*0Sstevel@tonic-gate Perl_find_threadsv(pTHX_ const char *name)
215*0Sstevel@tonic-gate {
216*0Sstevel@tonic-gate char *p;
217*0Sstevel@tonic-gate PADOFFSET key;
218*0Sstevel@tonic-gate SV **svp;
219*0Sstevel@tonic-gate /* We currently only handle names of a single character */
220*0Sstevel@tonic-gate p = strchr(PL_threadsv_names, *name);
221*0Sstevel@tonic-gate if (!p)
222*0Sstevel@tonic-gate return NOT_IN_PAD;
223*0Sstevel@tonic-gate key = p - PL_threadsv_names;
224*0Sstevel@tonic-gate MUTEX_LOCK(&thr->mutex);
225*0Sstevel@tonic-gate svp = av_fetch(thr->threadsv, key, FALSE);
226*0Sstevel@tonic-gate if (svp)
227*0Sstevel@tonic-gate MUTEX_UNLOCK(&thr->mutex);
228*0Sstevel@tonic-gate else {
229*0Sstevel@tonic-gate SV *sv = NEWSV(0, 0);
230*0Sstevel@tonic-gate av_store(thr->threadsv, key, sv);
231*0Sstevel@tonic-gate thr->threadsvp = AvARRAY(thr->threadsv);
232*0Sstevel@tonic-gate MUTEX_UNLOCK(&thr->mutex);
233*0Sstevel@tonic-gate /*
234*0Sstevel@tonic-gate * Some magic variables used to be automagically initialised
235*0Sstevel@tonic-gate * in gv_fetchpv. Those which are now per-thread magicals get
236*0Sstevel@tonic-gate * initialised here instead.
237*0Sstevel@tonic-gate */
238*0Sstevel@tonic-gate switch (*name) {
239*0Sstevel@tonic-gate case '_':
240*0Sstevel@tonic-gate break;
241*0Sstevel@tonic-gate case ';':
242*0Sstevel@tonic-gate sv_setpv(sv, "\034");
243*0Sstevel@tonic-gate sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
244*0Sstevel@tonic-gate break;
245*0Sstevel@tonic-gate case '&':
246*0Sstevel@tonic-gate case '`':
247*0Sstevel@tonic-gate case '\'':
248*0Sstevel@tonic-gate PL_sawampersand = TRUE;
249*0Sstevel@tonic-gate /* FALL THROUGH */
250*0Sstevel@tonic-gate case '1':
251*0Sstevel@tonic-gate case '2':
252*0Sstevel@tonic-gate case '3':
253*0Sstevel@tonic-gate case '4':
254*0Sstevel@tonic-gate case '5':
255*0Sstevel@tonic-gate case '6':
256*0Sstevel@tonic-gate case '7':
257*0Sstevel@tonic-gate case '8':
258*0Sstevel@tonic-gate case '9':
259*0Sstevel@tonic-gate SvREADONLY_on(sv);
260*0Sstevel@tonic-gate /* FALL THROUGH */
261*0Sstevel@tonic-gate
262*0Sstevel@tonic-gate /* XXX %! tied to Errno.pm needs to be added here.
263*0Sstevel@tonic-gate * See gv_fetchpv(). */
264*0Sstevel@tonic-gate /* case '!': */
265*0Sstevel@tonic-gate
266*0Sstevel@tonic-gate default:
267*0Sstevel@tonic-gate sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
268*0Sstevel@tonic-gate }
269*0Sstevel@tonic-gate DEBUG_S(PerlIO_printf(Perl_error_log,
270*0Sstevel@tonic-gate "find_threadsv: new SV %p for $%s%c\n",
271*0Sstevel@tonic-gate sv, (*name < 32) ? "^" : "",
272*0Sstevel@tonic-gate (*name < 32) ? toCTRL(*name) : *name));
273*0Sstevel@tonic-gate }
274*0Sstevel@tonic-gate return key;
275*0Sstevel@tonic-gate }
276*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
277*0Sstevel@tonic-gate
278*0Sstevel@tonic-gate /* Destructor */
279*0Sstevel@tonic-gate
280*0Sstevel@tonic-gate void
Perl_op_free(pTHX_ OP * o)281*0Sstevel@tonic-gate Perl_op_free(pTHX_ OP *o)
282*0Sstevel@tonic-gate {
283*0Sstevel@tonic-gate register OP *kid, *nextkid;
284*0Sstevel@tonic-gate OPCODE type;
285*0Sstevel@tonic-gate
286*0Sstevel@tonic-gate if (!o || o->op_seq == (U16)-1)
287*0Sstevel@tonic-gate return;
288*0Sstevel@tonic-gate
289*0Sstevel@tonic-gate if (o->op_private & OPpREFCOUNTED) {
290*0Sstevel@tonic-gate switch (o->op_type) {
291*0Sstevel@tonic-gate case OP_LEAVESUB:
292*0Sstevel@tonic-gate case OP_LEAVESUBLV:
293*0Sstevel@tonic-gate case OP_LEAVEEVAL:
294*0Sstevel@tonic-gate case OP_LEAVE:
295*0Sstevel@tonic-gate case OP_SCOPE:
296*0Sstevel@tonic-gate case OP_LEAVEWRITE:
297*0Sstevel@tonic-gate OP_REFCNT_LOCK;
298*0Sstevel@tonic-gate if (OpREFCNT_dec(o)) {
299*0Sstevel@tonic-gate OP_REFCNT_UNLOCK;
300*0Sstevel@tonic-gate return;
301*0Sstevel@tonic-gate }
302*0Sstevel@tonic-gate OP_REFCNT_UNLOCK;
303*0Sstevel@tonic-gate break;
304*0Sstevel@tonic-gate default:
305*0Sstevel@tonic-gate break;
306*0Sstevel@tonic-gate }
307*0Sstevel@tonic-gate }
308*0Sstevel@tonic-gate
309*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
310*0Sstevel@tonic-gate for (kid = cUNOPo->op_first; kid; kid = nextkid) {
311*0Sstevel@tonic-gate nextkid = kid->op_sibling; /* Get before next freeing kid */
312*0Sstevel@tonic-gate op_free(kid);
313*0Sstevel@tonic-gate }
314*0Sstevel@tonic-gate }
315*0Sstevel@tonic-gate type = o->op_type;
316*0Sstevel@tonic-gate if (type == OP_NULL)
317*0Sstevel@tonic-gate type = (OPCODE)o->op_targ;
318*0Sstevel@tonic-gate
319*0Sstevel@tonic-gate /* COP* is not cleared by op_clear() so that we may track line
320*0Sstevel@tonic-gate * numbers etc even after null() */
321*0Sstevel@tonic-gate if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
322*0Sstevel@tonic-gate cop_free((COP*)o);
323*0Sstevel@tonic-gate
324*0Sstevel@tonic-gate op_clear(o);
325*0Sstevel@tonic-gate FreeOp(o);
326*0Sstevel@tonic-gate }
327*0Sstevel@tonic-gate
328*0Sstevel@tonic-gate void
Perl_op_clear(pTHX_ OP * o)329*0Sstevel@tonic-gate Perl_op_clear(pTHX_ OP *o)
330*0Sstevel@tonic-gate {
331*0Sstevel@tonic-gate
332*0Sstevel@tonic-gate switch (o->op_type) {
333*0Sstevel@tonic-gate case OP_NULL: /* Was holding old type, if any. */
334*0Sstevel@tonic-gate case OP_ENTEREVAL: /* Was holding hints. */
335*0Sstevel@tonic-gate #ifdef USE_5005THREADS
336*0Sstevel@tonic-gate case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
337*0Sstevel@tonic-gate #endif
338*0Sstevel@tonic-gate o->op_targ = 0;
339*0Sstevel@tonic-gate break;
340*0Sstevel@tonic-gate #ifdef USE_5005THREADS
341*0Sstevel@tonic-gate case OP_ENTERITER:
342*0Sstevel@tonic-gate if (!(o->op_flags & OPf_SPECIAL))
343*0Sstevel@tonic-gate break;
344*0Sstevel@tonic-gate /* FALL THROUGH */
345*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
346*0Sstevel@tonic-gate default:
347*0Sstevel@tonic-gate if (!(o->op_flags & OPf_REF)
348*0Sstevel@tonic-gate || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
349*0Sstevel@tonic-gate break;
350*0Sstevel@tonic-gate /* FALL THROUGH */
351*0Sstevel@tonic-gate case OP_GVSV:
352*0Sstevel@tonic-gate case OP_GV:
353*0Sstevel@tonic-gate case OP_AELEMFAST:
354*0Sstevel@tonic-gate if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
355*0Sstevel@tonic-gate /* not an OP_PADAV replacement */
356*0Sstevel@tonic-gate #ifdef USE_ITHREADS
357*0Sstevel@tonic-gate if (cPADOPo->op_padix > 0) {
358*0Sstevel@tonic-gate /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
359*0Sstevel@tonic-gate * may still exist on the pad */
360*0Sstevel@tonic-gate pad_swipe(cPADOPo->op_padix, TRUE);
361*0Sstevel@tonic-gate cPADOPo->op_padix = 0;
362*0Sstevel@tonic-gate }
363*0Sstevel@tonic-gate #else
364*0Sstevel@tonic-gate SvREFCNT_dec(cSVOPo->op_sv);
365*0Sstevel@tonic-gate cSVOPo->op_sv = Nullsv;
366*0Sstevel@tonic-gate #endif
367*0Sstevel@tonic-gate }
368*0Sstevel@tonic-gate break;
369*0Sstevel@tonic-gate case OP_METHOD_NAMED:
370*0Sstevel@tonic-gate case OP_CONST:
371*0Sstevel@tonic-gate SvREFCNT_dec(cSVOPo->op_sv);
372*0Sstevel@tonic-gate cSVOPo->op_sv = Nullsv;
373*0Sstevel@tonic-gate #ifdef USE_ITHREADS
374*0Sstevel@tonic-gate /** Bug #15654
375*0Sstevel@tonic-gate Even if op_clear does a pad_free for the target of the op,
376*0Sstevel@tonic-gate pad_free doesn't actually remove the sv that exists in the pad;
377*0Sstevel@tonic-gate instead it lives on. This results in that it could be reused as
378*0Sstevel@tonic-gate a target later on when the pad was reallocated.
379*0Sstevel@tonic-gate **/
380*0Sstevel@tonic-gate if(o->op_targ) {
381*0Sstevel@tonic-gate pad_swipe(o->op_targ,1);
382*0Sstevel@tonic-gate o->op_targ = 0;
383*0Sstevel@tonic-gate }
384*0Sstevel@tonic-gate #endif
385*0Sstevel@tonic-gate break;
386*0Sstevel@tonic-gate case OP_GOTO:
387*0Sstevel@tonic-gate case OP_NEXT:
388*0Sstevel@tonic-gate case OP_LAST:
389*0Sstevel@tonic-gate case OP_REDO:
390*0Sstevel@tonic-gate if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
391*0Sstevel@tonic-gate break;
392*0Sstevel@tonic-gate /* FALL THROUGH */
393*0Sstevel@tonic-gate case OP_TRANS:
394*0Sstevel@tonic-gate if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
395*0Sstevel@tonic-gate SvREFCNT_dec(cSVOPo->op_sv);
396*0Sstevel@tonic-gate cSVOPo->op_sv = Nullsv;
397*0Sstevel@tonic-gate }
398*0Sstevel@tonic-gate else {
399*0Sstevel@tonic-gate Safefree(cPVOPo->op_pv);
400*0Sstevel@tonic-gate cPVOPo->op_pv = Nullch;
401*0Sstevel@tonic-gate }
402*0Sstevel@tonic-gate break;
403*0Sstevel@tonic-gate case OP_SUBST:
404*0Sstevel@tonic-gate op_free(cPMOPo->op_pmreplroot);
405*0Sstevel@tonic-gate goto clear_pmop;
406*0Sstevel@tonic-gate case OP_PUSHRE:
407*0Sstevel@tonic-gate #ifdef USE_ITHREADS
408*0Sstevel@tonic-gate if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
409*0Sstevel@tonic-gate /* No GvIN_PAD_off here, because other references may still
410*0Sstevel@tonic-gate * exist on the pad */
411*0Sstevel@tonic-gate pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
412*0Sstevel@tonic-gate }
413*0Sstevel@tonic-gate #else
414*0Sstevel@tonic-gate SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
415*0Sstevel@tonic-gate #endif
416*0Sstevel@tonic-gate /* FALL THROUGH */
417*0Sstevel@tonic-gate case OP_MATCH:
418*0Sstevel@tonic-gate case OP_QR:
419*0Sstevel@tonic-gate clear_pmop:
420*0Sstevel@tonic-gate {
421*0Sstevel@tonic-gate HV *pmstash = PmopSTASH(cPMOPo);
422*0Sstevel@tonic-gate if (pmstash && SvREFCNT(pmstash)) {
423*0Sstevel@tonic-gate PMOP *pmop = HvPMROOT(pmstash);
424*0Sstevel@tonic-gate PMOP *lastpmop = NULL;
425*0Sstevel@tonic-gate while (pmop) {
426*0Sstevel@tonic-gate if (cPMOPo == pmop) {
427*0Sstevel@tonic-gate if (lastpmop)
428*0Sstevel@tonic-gate lastpmop->op_pmnext = pmop->op_pmnext;
429*0Sstevel@tonic-gate else
430*0Sstevel@tonic-gate HvPMROOT(pmstash) = pmop->op_pmnext;
431*0Sstevel@tonic-gate break;
432*0Sstevel@tonic-gate }
433*0Sstevel@tonic-gate lastpmop = pmop;
434*0Sstevel@tonic-gate pmop = pmop->op_pmnext;
435*0Sstevel@tonic-gate }
436*0Sstevel@tonic-gate }
437*0Sstevel@tonic-gate PmopSTASH_free(cPMOPo);
438*0Sstevel@tonic-gate }
439*0Sstevel@tonic-gate cPMOPo->op_pmreplroot = Nullop;
440*0Sstevel@tonic-gate /* we use the "SAFE" version of the PM_ macros here
441*0Sstevel@tonic-gate * since sv_clean_all might release some PMOPs
442*0Sstevel@tonic-gate * after PL_regex_padav has been cleared
443*0Sstevel@tonic-gate * and the clearing of PL_regex_padav needs to
444*0Sstevel@tonic-gate * happen before sv_clean_all
445*0Sstevel@tonic-gate */
446*0Sstevel@tonic-gate ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
447*0Sstevel@tonic-gate PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
448*0Sstevel@tonic-gate #ifdef USE_ITHREADS
449*0Sstevel@tonic-gate if(PL_regex_pad) { /* We could be in destruction */
450*0Sstevel@tonic-gate av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
451*0Sstevel@tonic-gate SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
452*0Sstevel@tonic-gate PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
453*0Sstevel@tonic-gate }
454*0Sstevel@tonic-gate #endif
455*0Sstevel@tonic-gate
456*0Sstevel@tonic-gate break;
457*0Sstevel@tonic-gate }
458*0Sstevel@tonic-gate
459*0Sstevel@tonic-gate if (o->op_targ > 0) {
460*0Sstevel@tonic-gate pad_free(o->op_targ);
461*0Sstevel@tonic-gate o->op_targ = 0;
462*0Sstevel@tonic-gate }
463*0Sstevel@tonic-gate }
464*0Sstevel@tonic-gate
465*0Sstevel@tonic-gate STATIC void
S_cop_free(pTHX_ COP * cop)466*0Sstevel@tonic-gate S_cop_free(pTHX_ COP* cop)
467*0Sstevel@tonic-gate {
468*0Sstevel@tonic-gate Safefree(cop->cop_label); /* FIXME: treaddead ??? */
469*0Sstevel@tonic-gate CopFILE_free(cop);
470*0Sstevel@tonic-gate CopSTASH_free(cop);
471*0Sstevel@tonic-gate if (! specialWARN(cop->cop_warnings))
472*0Sstevel@tonic-gate SvREFCNT_dec(cop->cop_warnings);
473*0Sstevel@tonic-gate if (! specialCopIO(cop->cop_io)) {
474*0Sstevel@tonic-gate #ifdef USE_ITHREADS
475*0Sstevel@tonic-gate #if 0
476*0Sstevel@tonic-gate STRLEN len;
477*0Sstevel@tonic-gate char *s = SvPV(cop->cop_io,len);
478*0Sstevel@tonic-gate Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
479*0Sstevel@tonic-gate #endif
480*0Sstevel@tonic-gate #else
481*0Sstevel@tonic-gate SvREFCNT_dec(cop->cop_io);
482*0Sstevel@tonic-gate #endif
483*0Sstevel@tonic-gate }
484*0Sstevel@tonic-gate }
485*0Sstevel@tonic-gate
486*0Sstevel@tonic-gate void
Perl_op_null(pTHX_ OP * o)487*0Sstevel@tonic-gate Perl_op_null(pTHX_ OP *o)
488*0Sstevel@tonic-gate {
489*0Sstevel@tonic-gate if (o->op_type == OP_NULL)
490*0Sstevel@tonic-gate return;
491*0Sstevel@tonic-gate op_clear(o);
492*0Sstevel@tonic-gate o->op_targ = o->op_type;
493*0Sstevel@tonic-gate o->op_type = OP_NULL;
494*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_NULL];
495*0Sstevel@tonic-gate }
496*0Sstevel@tonic-gate
497*0Sstevel@tonic-gate /* Contextualizers */
498*0Sstevel@tonic-gate
499*0Sstevel@tonic-gate #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
500*0Sstevel@tonic-gate
501*0Sstevel@tonic-gate OP *
Perl_linklist(pTHX_ OP * o)502*0Sstevel@tonic-gate Perl_linklist(pTHX_ OP *o)
503*0Sstevel@tonic-gate {
504*0Sstevel@tonic-gate register OP *kid;
505*0Sstevel@tonic-gate
506*0Sstevel@tonic-gate if (o->op_next)
507*0Sstevel@tonic-gate return o->op_next;
508*0Sstevel@tonic-gate
509*0Sstevel@tonic-gate /* establish postfix order */
510*0Sstevel@tonic-gate if (cUNOPo->op_first) {
511*0Sstevel@tonic-gate o->op_next = LINKLIST(cUNOPo->op_first);
512*0Sstevel@tonic-gate for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
513*0Sstevel@tonic-gate if (kid->op_sibling)
514*0Sstevel@tonic-gate kid->op_next = LINKLIST(kid->op_sibling);
515*0Sstevel@tonic-gate else
516*0Sstevel@tonic-gate kid->op_next = o;
517*0Sstevel@tonic-gate }
518*0Sstevel@tonic-gate }
519*0Sstevel@tonic-gate else
520*0Sstevel@tonic-gate o->op_next = o;
521*0Sstevel@tonic-gate
522*0Sstevel@tonic-gate return o->op_next;
523*0Sstevel@tonic-gate }
524*0Sstevel@tonic-gate
525*0Sstevel@tonic-gate OP *
Perl_scalarkids(pTHX_ OP * o)526*0Sstevel@tonic-gate Perl_scalarkids(pTHX_ OP *o)
527*0Sstevel@tonic-gate {
528*0Sstevel@tonic-gate OP *kid;
529*0Sstevel@tonic-gate if (o && o->op_flags & OPf_KIDS) {
530*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
531*0Sstevel@tonic-gate scalar(kid);
532*0Sstevel@tonic-gate }
533*0Sstevel@tonic-gate return o;
534*0Sstevel@tonic-gate }
535*0Sstevel@tonic-gate
536*0Sstevel@tonic-gate STATIC OP *
S_scalarboolean(pTHX_ OP * o)537*0Sstevel@tonic-gate S_scalarboolean(pTHX_ OP *o)
538*0Sstevel@tonic-gate {
539*0Sstevel@tonic-gate if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
540*0Sstevel@tonic-gate if (ckWARN(WARN_SYNTAX)) {
541*0Sstevel@tonic-gate line_t oldline = CopLINE(PL_curcop);
542*0Sstevel@tonic-gate
543*0Sstevel@tonic-gate if (PL_copline != NOLINE)
544*0Sstevel@tonic-gate CopLINE_set(PL_curcop, PL_copline);
545*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
546*0Sstevel@tonic-gate CopLINE_set(PL_curcop, oldline);
547*0Sstevel@tonic-gate }
548*0Sstevel@tonic-gate }
549*0Sstevel@tonic-gate return scalar(o);
550*0Sstevel@tonic-gate }
551*0Sstevel@tonic-gate
552*0Sstevel@tonic-gate OP *
Perl_scalar(pTHX_ OP * o)553*0Sstevel@tonic-gate Perl_scalar(pTHX_ OP *o)
554*0Sstevel@tonic-gate {
555*0Sstevel@tonic-gate OP *kid;
556*0Sstevel@tonic-gate
557*0Sstevel@tonic-gate /* assumes no premature commitment */
558*0Sstevel@tonic-gate if (!o || (o->op_flags & OPf_WANT) || PL_error_count
559*0Sstevel@tonic-gate || o->op_type == OP_RETURN)
560*0Sstevel@tonic-gate {
561*0Sstevel@tonic-gate return o;
562*0Sstevel@tonic-gate }
563*0Sstevel@tonic-gate
564*0Sstevel@tonic-gate o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
565*0Sstevel@tonic-gate
566*0Sstevel@tonic-gate switch (o->op_type) {
567*0Sstevel@tonic-gate case OP_REPEAT:
568*0Sstevel@tonic-gate scalar(cBINOPo->op_first);
569*0Sstevel@tonic-gate break;
570*0Sstevel@tonic-gate case OP_OR:
571*0Sstevel@tonic-gate case OP_AND:
572*0Sstevel@tonic-gate case OP_COND_EXPR:
573*0Sstevel@tonic-gate for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
574*0Sstevel@tonic-gate scalar(kid);
575*0Sstevel@tonic-gate break;
576*0Sstevel@tonic-gate case OP_SPLIT:
577*0Sstevel@tonic-gate if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
578*0Sstevel@tonic-gate if (!kPMOP->op_pmreplroot)
579*0Sstevel@tonic-gate deprecate_old("implicit split to @_");
580*0Sstevel@tonic-gate }
581*0Sstevel@tonic-gate /* FALL THROUGH */
582*0Sstevel@tonic-gate case OP_MATCH:
583*0Sstevel@tonic-gate case OP_QR:
584*0Sstevel@tonic-gate case OP_SUBST:
585*0Sstevel@tonic-gate case OP_NULL:
586*0Sstevel@tonic-gate default:
587*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
588*0Sstevel@tonic-gate for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
589*0Sstevel@tonic-gate scalar(kid);
590*0Sstevel@tonic-gate }
591*0Sstevel@tonic-gate break;
592*0Sstevel@tonic-gate case OP_LEAVE:
593*0Sstevel@tonic-gate case OP_LEAVETRY:
594*0Sstevel@tonic-gate kid = cLISTOPo->op_first;
595*0Sstevel@tonic-gate scalar(kid);
596*0Sstevel@tonic-gate while ((kid = kid->op_sibling)) {
597*0Sstevel@tonic-gate if (kid->op_sibling)
598*0Sstevel@tonic-gate scalarvoid(kid);
599*0Sstevel@tonic-gate else
600*0Sstevel@tonic-gate scalar(kid);
601*0Sstevel@tonic-gate }
602*0Sstevel@tonic-gate WITH_THR(PL_curcop = &PL_compiling);
603*0Sstevel@tonic-gate break;
604*0Sstevel@tonic-gate case OP_SCOPE:
605*0Sstevel@tonic-gate case OP_LINESEQ:
606*0Sstevel@tonic-gate case OP_LIST:
607*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
608*0Sstevel@tonic-gate if (kid->op_sibling)
609*0Sstevel@tonic-gate scalarvoid(kid);
610*0Sstevel@tonic-gate else
611*0Sstevel@tonic-gate scalar(kid);
612*0Sstevel@tonic-gate }
613*0Sstevel@tonic-gate WITH_THR(PL_curcop = &PL_compiling);
614*0Sstevel@tonic-gate break;
615*0Sstevel@tonic-gate case OP_SORT:
616*0Sstevel@tonic-gate if (ckWARN(WARN_VOID))
617*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
618*0Sstevel@tonic-gate }
619*0Sstevel@tonic-gate return o;
620*0Sstevel@tonic-gate }
621*0Sstevel@tonic-gate
622*0Sstevel@tonic-gate OP *
Perl_scalarvoid(pTHX_ OP * o)623*0Sstevel@tonic-gate Perl_scalarvoid(pTHX_ OP *o)
624*0Sstevel@tonic-gate {
625*0Sstevel@tonic-gate OP *kid;
626*0Sstevel@tonic-gate char* useless = 0;
627*0Sstevel@tonic-gate SV* sv;
628*0Sstevel@tonic-gate U8 want;
629*0Sstevel@tonic-gate
630*0Sstevel@tonic-gate if (o->op_type == OP_NEXTSTATE
631*0Sstevel@tonic-gate || o->op_type == OP_SETSTATE
632*0Sstevel@tonic-gate || o->op_type == OP_DBSTATE
633*0Sstevel@tonic-gate || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
634*0Sstevel@tonic-gate || o->op_targ == OP_SETSTATE
635*0Sstevel@tonic-gate || o->op_targ == OP_DBSTATE)))
636*0Sstevel@tonic-gate PL_curcop = (COP*)o; /* for warning below */
637*0Sstevel@tonic-gate
638*0Sstevel@tonic-gate /* assumes no premature commitment */
639*0Sstevel@tonic-gate want = o->op_flags & OPf_WANT;
640*0Sstevel@tonic-gate if ((want && want != OPf_WANT_SCALAR) || PL_error_count
641*0Sstevel@tonic-gate || o->op_type == OP_RETURN)
642*0Sstevel@tonic-gate {
643*0Sstevel@tonic-gate return o;
644*0Sstevel@tonic-gate }
645*0Sstevel@tonic-gate
646*0Sstevel@tonic-gate if ((o->op_private & OPpTARGET_MY)
647*0Sstevel@tonic-gate && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
648*0Sstevel@tonic-gate {
649*0Sstevel@tonic-gate return scalar(o); /* As if inside SASSIGN */
650*0Sstevel@tonic-gate }
651*0Sstevel@tonic-gate
652*0Sstevel@tonic-gate o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
653*0Sstevel@tonic-gate
654*0Sstevel@tonic-gate switch (o->op_type) {
655*0Sstevel@tonic-gate default:
656*0Sstevel@tonic-gate if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
657*0Sstevel@tonic-gate break;
658*0Sstevel@tonic-gate /* FALL THROUGH */
659*0Sstevel@tonic-gate case OP_REPEAT:
660*0Sstevel@tonic-gate if (o->op_flags & OPf_STACKED)
661*0Sstevel@tonic-gate break;
662*0Sstevel@tonic-gate goto func_ops;
663*0Sstevel@tonic-gate case OP_SUBSTR:
664*0Sstevel@tonic-gate if (o->op_private == 4)
665*0Sstevel@tonic-gate break;
666*0Sstevel@tonic-gate /* FALL THROUGH */
667*0Sstevel@tonic-gate case OP_GVSV:
668*0Sstevel@tonic-gate case OP_WANTARRAY:
669*0Sstevel@tonic-gate case OP_GV:
670*0Sstevel@tonic-gate case OP_PADSV:
671*0Sstevel@tonic-gate case OP_PADAV:
672*0Sstevel@tonic-gate case OP_PADHV:
673*0Sstevel@tonic-gate case OP_PADANY:
674*0Sstevel@tonic-gate case OP_AV2ARYLEN:
675*0Sstevel@tonic-gate case OP_REF:
676*0Sstevel@tonic-gate case OP_REFGEN:
677*0Sstevel@tonic-gate case OP_SREFGEN:
678*0Sstevel@tonic-gate case OP_DEFINED:
679*0Sstevel@tonic-gate case OP_HEX:
680*0Sstevel@tonic-gate case OP_OCT:
681*0Sstevel@tonic-gate case OP_LENGTH:
682*0Sstevel@tonic-gate case OP_VEC:
683*0Sstevel@tonic-gate case OP_INDEX:
684*0Sstevel@tonic-gate case OP_RINDEX:
685*0Sstevel@tonic-gate case OP_SPRINTF:
686*0Sstevel@tonic-gate case OP_AELEM:
687*0Sstevel@tonic-gate case OP_AELEMFAST:
688*0Sstevel@tonic-gate case OP_ASLICE:
689*0Sstevel@tonic-gate case OP_HELEM:
690*0Sstevel@tonic-gate case OP_HSLICE:
691*0Sstevel@tonic-gate case OP_UNPACK:
692*0Sstevel@tonic-gate case OP_PACK:
693*0Sstevel@tonic-gate case OP_JOIN:
694*0Sstevel@tonic-gate case OP_LSLICE:
695*0Sstevel@tonic-gate case OP_ANONLIST:
696*0Sstevel@tonic-gate case OP_ANONHASH:
697*0Sstevel@tonic-gate case OP_SORT:
698*0Sstevel@tonic-gate case OP_REVERSE:
699*0Sstevel@tonic-gate case OP_RANGE:
700*0Sstevel@tonic-gate case OP_FLIP:
701*0Sstevel@tonic-gate case OP_FLOP:
702*0Sstevel@tonic-gate case OP_CALLER:
703*0Sstevel@tonic-gate case OP_FILENO:
704*0Sstevel@tonic-gate case OP_EOF:
705*0Sstevel@tonic-gate case OP_TELL:
706*0Sstevel@tonic-gate case OP_GETSOCKNAME:
707*0Sstevel@tonic-gate case OP_GETPEERNAME:
708*0Sstevel@tonic-gate case OP_READLINK:
709*0Sstevel@tonic-gate case OP_TELLDIR:
710*0Sstevel@tonic-gate case OP_GETPPID:
711*0Sstevel@tonic-gate case OP_GETPGRP:
712*0Sstevel@tonic-gate case OP_GETPRIORITY:
713*0Sstevel@tonic-gate case OP_TIME:
714*0Sstevel@tonic-gate case OP_TMS:
715*0Sstevel@tonic-gate case OP_LOCALTIME:
716*0Sstevel@tonic-gate case OP_GMTIME:
717*0Sstevel@tonic-gate case OP_GHBYNAME:
718*0Sstevel@tonic-gate case OP_GHBYADDR:
719*0Sstevel@tonic-gate case OP_GHOSTENT:
720*0Sstevel@tonic-gate case OP_GNBYNAME:
721*0Sstevel@tonic-gate case OP_GNBYADDR:
722*0Sstevel@tonic-gate case OP_GNETENT:
723*0Sstevel@tonic-gate case OP_GPBYNAME:
724*0Sstevel@tonic-gate case OP_GPBYNUMBER:
725*0Sstevel@tonic-gate case OP_GPROTOENT:
726*0Sstevel@tonic-gate case OP_GSBYNAME:
727*0Sstevel@tonic-gate case OP_GSBYPORT:
728*0Sstevel@tonic-gate case OP_GSERVENT:
729*0Sstevel@tonic-gate case OP_GPWNAM:
730*0Sstevel@tonic-gate case OP_GPWUID:
731*0Sstevel@tonic-gate case OP_GGRNAM:
732*0Sstevel@tonic-gate case OP_GGRGID:
733*0Sstevel@tonic-gate case OP_GETLOGIN:
734*0Sstevel@tonic-gate case OP_PROTOTYPE:
735*0Sstevel@tonic-gate func_ops:
736*0Sstevel@tonic-gate if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
737*0Sstevel@tonic-gate useless = OP_DESC(o);
738*0Sstevel@tonic-gate break;
739*0Sstevel@tonic-gate
740*0Sstevel@tonic-gate case OP_RV2GV:
741*0Sstevel@tonic-gate case OP_RV2SV:
742*0Sstevel@tonic-gate case OP_RV2AV:
743*0Sstevel@tonic-gate case OP_RV2HV:
744*0Sstevel@tonic-gate if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
745*0Sstevel@tonic-gate (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
746*0Sstevel@tonic-gate useless = "a variable";
747*0Sstevel@tonic-gate break;
748*0Sstevel@tonic-gate
749*0Sstevel@tonic-gate case OP_CONST:
750*0Sstevel@tonic-gate sv = cSVOPo_sv;
751*0Sstevel@tonic-gate if (cSVOPo->op_private & OPpCONST_STRICT)
752*0Sstevel@tonic-gate no_bareword_allowed(o);
753*0Sstevel@tonic-gate else {
754*0Sstevel@tonic-gate if (ckWARN(WARN_VOID)) {
755*0Sstevel@tonic-gate useless = "a constant";
756*0Sstevel@tonic-gate /* don't warn on optimised away booleans, eg
757*0Sstevel@tonic-gate * use constant Foo, 5; Foo || print; */
758*0Sstevel@tonic-gate if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
759*0Sstevel@tonic-gate useless = 0;
760*0Sstevel@tonic-gate /* the constants 0 and 1 are permitted as they are
761*0Sstevel@tonic-gate conventionally used as dummies in constructs like
762*0Sstevel@tonic-gate 1 while some_condition_with_side_effects; */
763*0Sstevel@tonic-gate else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
764*0Sstevel@tonic-gate useless = 0;
765*0Sstevel@tonic-gate else if (SvPOK(sv)) {
766*0Sstevel@tonic-gate /* perl4's way of mixing documentation and code
767*0Sstevel@tonic-gate (before the invention of POD) was based on a
768*0Sstevel@tonic-gate trick to mix nroff and perl code. The trick was
769*0Sstevel@tonic-gate built upon these three nroff macros being used in
770*0Sstevel@tonic-gate void context. The pink camel has the details in
771*0Sstevel@tonic-gate the script wrapman near page 319. */
772*0Sstevel@tonic-gate if (strnEQ(SvPVX(sv), "di", 2) ||
773*0Sstevel@tonic-gate strnEQ(SvPVX(sv), "ds", 2) ||
774*0Sstevel@tonic-gate strnEQ(SvPVX(sv), "ig", 2))
775*0Sstevel@tonic-gate useless = 0;
776*0Sstevel@tonic-gate }
777*0Sstevel@tonic-gate }
778*0Sstevel@tonic-gate }
779*0Sstevel@tonic-gate op_null(o); /* don't execute or even remember it */
780*0Sstevel@tonic-gate break;
781*0Sstevel@tonic-gate
782*0Sstevel@tonic-gate case OP_POSTINC:
783*0Sstevel@tonic-gate o->op_type = OP_PREINC; /* pre-increment is faster */
784*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_PREINC];
785*0Sstevel@tonic-gate break;
786*0Sstevel@tonic-gate
787*0Sstevel@tonic-gate case OP_POSTDEC:
788*0Sstevel@tonic-gate o->op_type = OP_PREDEC; /* pre-decrement is faster */
789*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_PREDEC];
790*0Sstevel@tonic-gate break;
791*0Sstevel@tonic-gate
792*0Sstevel@tonic-gate case OP_OR:
793*0Sstevel@tonic-gate case OP_AND:
794*0Sstevel@tonic-gate case OP_COND_EXPR:
795*0Sstevel@tonic-gate for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
796*0Sstevel@tonic-gate scalarvoid(kid);
797*0Sstevel@tonic-gate break;
798*0Sstevel@tonic-gate
799*0Sstevel@tonic-gate case OP_NULL:
800*0Sstevel@tonic-gate if (o->op_flags & OPf_STACKED)
801*0Sstevel@tonic-gate break;
802*0Sstevel@tonic-gate /* FALL THROUGH */
803*0Sstevel@tonic-gate case OP_NEXTSTATE:
804*0Sstevel@tonic-gate case OP_DBSTATE:
805*0Sstevel@tonic-gate case OP_ENTERTRY:
806*0Sstevel@tonic-gate case OP_ENTER:
807*0Sstevel@tonic-gate if (!(o->op_flags & OPf_KIDS))
808*0Sstevel@tonic-gate break;
809*0Sstevel@tonic-gate /* FALL THROUGH */
810*0Sstevel@tonic-gate case OP_SCOPE:
811*0Sstevel@tonic-gate case OP_LEAVE:
812*0Sstevel@tonic-gate case OP_LEAVETRY:
813*0Sstevel@tonic-gate case OP_LEAVELOOP:
814*0Sstevel@tonic-gate case OP_LINESEQ:
815*0Sstevel@tonic-gate case OP_LIST:
816*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
817*0Sstevel@tonic-gate scalarvoid(kid);
818*0Sstevel@tonic-gate break;
819*0Sstevel@tonic-gate case OP_ENTEREVAL:
820*0Sstevel@tonic-gate scalarkids(o);
821*0Sstevel@tonic-gate break;
822*0Sstevel@tonic-gate case OP_REQUIRE:
823*0Sstevel@tonic-gate /* all requires must return a boolean value */
824*0Sstevel@tonic-gate o->op_flags &= ~OPf_WANT;
825*0Sstevel@tonic-gate /* FALL THROUGH */
826*0Sstevel@tonic-gate case OP_SCALAR:
827*0Sstevel@tonic-gate return scalar(o);
828*0Sstevel@tonic-gate case OP_SPLIT:
829*0Sstevel@tonic-gate if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
830*0Sstevel@tonic-gate if (!kPMOP->op_pmreplroot)
831*0Sstevel@tonic-gate deprecate_old("implicit split to @_");
832*0Sstevel@tonic-gate }
833*0Sstevel@tonic-gate break;
834*0Sstevel@tonic-gate }
835*0Sstevel@tonic-gate if (useless && ckWARN(WARN_VOID))
836*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
837*0Sstevel@tonic-gate return o;
838*0Sstevel@tonic-gate }
839*0Sstevel@tonic-gate
840*0Sstevel@tonic-gate OP *
Perl_listkids(pTHX_ OP * o)841*0Sstevel@tonic-gate Perl_listkids(pTHX_ OP *o)
842*0Sstevel@tonic-gate {
843*0Sstevel@tonic-gate OP *kid;
844*0Sstevel@tonic-gate if (o && o->op_flags & OPf_KIDS) {
845*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
846*0Sstevel@tonic-gate list(kid);
847*0Sstevel@tonic-gate }
848*0Sstevel@tonic-gate return o;
849*0Sstevel@tonic-gate }
850*0Sstevel@tonic-gate
851*0Sstevel@tonic-gate OP *
Perl_list(pTHX_ OP * o)852*0Sstevel@tonic-gate Perl_list(pTHX_ OP *o)
853*0Sstevel@tonic-gate {
854*0Sstevel@tonic-gate OP *kid;
855*0Sstevel@tonic-gate
856*0Sstevel@tonic-gate /* assumes no premature commitment */
857*0Sstevel@tonic-gate if (!o || (o->op_flags & OPf_WANT) || PL_error_count
858*0Sstevel@tonic-gate || o->op_type == OP_RETURN)
859*0Sstevel@tonic-gate {
860*0Sstevel@tonic-gate return o;
861*0Sstevel@tonic-gate }
862*0Sstevel@tonic-gate
863*0Sstevel@tonic-gate if ((o->op_private & OPpTARGET_MY)
864*0Sstevel@tonic-gate && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
865*0Sstevel@tonic-gate {
866*0Sstevel@tonic-gate return o; /* As if inside SASSIGN */
867*0Sstevel@tonic-gate }
868*0Sstevel@tonic-gate
869*0Sstevel@tonic-gate o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
870*0Sstevel@tonic-gate
871*0Sstevel@tonic-gate switch (o->op_type) {
872*0Sstevel@tonic-gate case OP_FLOP:
873*0Sstevel@tonic-gate case OP_REPEAT:
874*0Sstevel@tonic-gate list(cBINOPo->op_first);
875*0Sstevel@tonic-gate break;
876*0Sstevel@tonic-gate case OP_OR:
877*0Sstevel@tonic-gate case OP_AND:
878*0Sstevel@tonic-gate case OP_COND_EXPR:
879*0Sstevel@tonic-gate for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
880*0Sstevel@tonic-gate list(kid);
881*0Sstevel@tonic-gate break;
882*0Sstevel@tonic-gate default:
883*0Sstevel@tonic-gate case OP_MATCH:
884*0Sstevel@tonic-gate case OP_QR:
885*0Sstevel@tonic-gate case OP_SUBST:
886*0Sstevel@tonic-gate case OP_NULL:
887*0Sstevel@tonic-gate if (!(o->op_flags & OPf_KIDS))
888*0Sstevel@tonic-gate break;
889*0Sstevel@tonic-gate if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
890*0Sstevel@tonic-gate list(cBINOPo->op_first);
891*0Sstevel@tonic-gate return gen_constant_list(o);
892*0Sstevel@tonic-gate }
893*0Sstevel@tonic-gate case OP_LIST:
894*0Sstevel@tonic-gate listkids(o);
895*0Sstevel@tonic-gate break;
896*0Sstevel@tonic-gate case OP_LEAVE:
897*0Sstevel@tonic-gate case OP_LEAVETRY:
898*0Sstevel@tonic-gate kid = cLISTOPo->op_first;
899*0Sstevel@tonic-gate list(kid);
900*0Sstevel@tonic-gate while ((kid = kid->op_sibling)) {
901*0Sstevel@tonic-gate if (kid->op_sibling)
902*0Sstevel@tonic-gate scalarvoid(kid);
903*0Sstevel@tonic-gate else
904*0Sstevel@tonic-gate list(kid);
905*0Sstevel@tonic-gate }
906*0Sstevel@tonic-gate WITH_THR(PL_curcop = &PL_compiling);
907*0Sstevel@tonic-gate break;
908*0Sstevel@tonic-gate case OP_SCOPE:
909*0Sstevel@tonic-gate case OP_LINESEQ:
910*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
911*0Sstevel@tonic-gate if (kid->op_sibling)
912*0Sstevel@tonic-gate scalarvoid(kid);
913*0Sstevel@tonic-gate else
914*0Sstevel@tonic-gate list(kid);
915*0Sstevel@tonic-gate }
916*0Sstevel@tonic-gate WITH_THR(PL_curcop = &PL_compiling);
917*0Sstevel@tonic-gate break;
918*0Sstevel@tonic-gate case OP_REQUIRE:
919*0Sstevel@tonic-gate /* all requires must return a boolean value */
920*0Sstevel@tonic-gate o->op_flags &= ~OPf_WANT;
921*0Sstevel@tonic-gate return scalar(o);
922*0Sstevel@tonic-gate }
923*0Sstevel@tonic-gate return o;
924*0Sstevel@tonic-gate }
925*0Sstevel@tonic-gate
926*0Sstevel@tonic-gate OP *
Perl_scalarseq(pTHX_ OP * o)927*0Sstevel@tonic-gate Perl_scalarseq(pTHX_ OP *o)
928*0Sstevel@tonic-gate {
929*0Sstevel@tonic-gate OP *kid;
930*0Sstevel@tonic-gate
931*0Sstevel@tonic-gate if (o) {
932*0Sstevel@tonic-gate if (o->op_type == OP_LINESEQ ||
933*0Sstevel@tonic-gate o->op_type == OP_SCOPE ||
934*0Sstevel@tonic-gate o->op_type == OP_LEAVE ||
935*0Sstevel@tonic-gate o->op_type == OP_LEAVETRY)
936*0Sstevel@tonic-gate {
937*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
938*0Sstevel@tonic-gate if (kid->op_sibling) {
939*0Sstevel@tonic-gate scalarvoid(kid);
940*0Sstevel@tonic-gate }
941*0Sstevel@tonic-gate }
942*0Sstevel@tonic-gate PL_curcop = &PL_compiling;
943*0Sstevel@tonic-gate }
944*0Sstevel@tonic-gate o->op_flags &= ~OPf_PARENS;
945*0Sstevel@tonic-gate if (PL_hints & HINT_BLOCK_SCOPE)
946*0Sstevel@tonic-gate o->op_flags |= OPf_PARENS;
947*0Sstevel@tonic-gate }
948*0Sstevel@tonic-gate else
949*0Sstevel@tonic-gate o = newOP(OP_STUB, 0);
950*0Sstevel@tonic-gate return o;
951*0Sstevel@tonic-gate }
952*0Sstevel@tonic-gate
953*0Sstevel@tonic-gate STATIC OP *
S_modkids(pTHX_ OP * o,I32 type)954*0Sstevel@tonic-gate S_modkids(pTHX_ OP *o, I32 type)
955*0Sstevel@tonic-gate {
956*0Sstevel@tonic-gate OP *kid;
957*0Sstevel@tonic-gate if (o && o->op_flags & OPf_KIDS) {
958*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
959*0Sstevel@tonic-gate mod(kid, type);
960*0Sstevel@tonic-gate }
961*0Sstevel@tonic-gate return o;
962*0Sstevel@tonic-gate }
963*0Sstevel@tonic-gate
964*0Sstevel@tonic-gate OP *
Perl_mod(pTHX_ OP * o,I32 type)965*0Sstevel@tonic-gate Perl_mod(pTHX_ OP *o, I32 type)
966*0Sstevel@tonic-gate {
967*0Sstevel@tonic-gate OP *kid;
968*0Sstevel@tonic-gate
969*0Sstevel@tonic-gate if (!o || PL_error_count)
970*0Sstevel@tonic-gate return o;
971*0Sstevel@tonic-gate
972*0Sstevel@tonic-gate if ((o->op_private & OPpTARGET_MY)
973*0Sstevel@tonic-gate && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
974*0Sstevel@tonic-gate {
975*0Sstevel@tonic-gate return o;
976*0Sstevel@tonic-gate }
977*0Sstevel@tonic-gate
978*0Sstevel@tonic-gate switch (o->op_type) {
979*0Sstevel@tonic-gate case OP_UNDEF:
980*0Sstevel@tonic-gate PL_modcount++;
981*0Sstevel@tonic-gate return o;
982*0Sstevel@tonic-gate case OP_CONST:
983*0Sstevel@tonic-gate if (!(o->op_private & (OPpCONST_ARYBASE)))
984*0Sstevel@tonic-gate goto nomod;
985*0Sstevel@tonic-gate if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
986*0Sstevel@tonic-gate PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
987*0Sstevel@tonic-gate PL_eval_start = 0;
988*0Sstevel@tonic-gate }
989*0Sstevel@tonic-gate else if (!type) {
990*0Sstevel@tonic-gate SAVEI32(PL_compiling.cop_arybase);
991*0Sstevel@tonic-gate PL_compiling.cop_arybase = 0;
992*0Sstevel@tonic-gate }
993*0Sstevel@tonic-gate else if (type == OP_REFGEN)
994*0Sstevel@tonic-gate goto nomod;
995*0Sstevel@tonic-gate else
996*0Sstevel@tonic-gate Perl_croak(aTHX_ "That use of $[ is unsupported");
997*0Sstevel@tonic-gate break;
998*0Sstevel@tonic-gate case OP_STUB:
999*0Sstevel@tonic-gate if (o->op_flags & OPf_PARENS)
1000*0Sstevel@tonic-gate break;
1001*0Sstevel@tonic-gate goto nomod;
1002*0Sstevel@tonic-gate case OP_ENTERSUB:
1003*0Sstevel@tonic-gate if ((type == OP_UNDEF || type == OP_REFGEN) &&
1004*0Sstevel@tonic-gate !(o->op_flags & OPf_STACKED)) {
1005*0Sstevel@tonic-gate o->op_type = OP_RV2CV; /* entersub => rv2cv */
1006*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1007*0Sstevel@tonic-gate assert(cUNOPo->op_first->op_type == OP_NULL);
1008*0Sstevel@tonic-gate op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1009*0Sstevel@tonic-gate break;
1010*0Sstevel@tonic-gate }
1011*0Sstevel@tonic-gate else if (o->op_private & OPpENTERSUB_NOMOD)
1012*0Sstevel@tonic-gate return o;
1013*0Sstevel@tonic-gate else { /* lvalue subroutine call */
1014*0Sstevel@tonic-gate o->op_private |= OPpLVAL_INTRO;
1015*0Sstevel@tonic-gate PL_modcount = RETURN_UNLIMITED_NUMBER;
1016*0Sstevel@tonic-gate if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1017*0Sstevel@tonic-gate /* Backward compatibility mode: */
1018*0Sstevel@tonic-gate o->op_private |= OPpENTERSUB_INARGS;
1019*0Sstevel@tonic-gate break;
1020*0Sstevel@tonic-gate }
1021*0Sstevel@tonic-gate else { /* Compile-time error message: */
1022*0Sstevel@tonic-gate OP *kid = cUNOPo->op_first;
1023*0Sstevel@tonic-gate CV *cv;
1024*0Sstevel@tonic-gate OP *okid;
1025*0Sstevel@tonic-gate
1026*0Sstevel@tonic-gate if (kid->op_type == OP_PUSHMARK)
1027*0Sstevel@tonic-gate goto skip_kids;
1028*0Sstevel@tonic-gate if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1029*0Sstevel@tonic-gate Perl_croak(aTHX_
1030*0Sstevel@tonic-gate "panic: unexpected lvalue entersub "
1031*0Sstevel@tonic-gate "args: type/targ %ld:%"UVuf,
1032*0Sstevel@tonic-gate (long)kid->op_type, (UV)kid->op_targ);
1033*0Sstevel@tonic-gate kid = kLISTOP->op_first;
1034*0Sstevel@tonic-gate skip_kids:
1035*0Sstevel@tonic-gate while (kid->op_sibling)
1036*0Sstevel@tonic-gate kid = kid->op_sibling;
1037*0Sstevel@tonic-gate if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1038*0Sstevel@tonic-gate /* Indirect call */
1039*0Sstevel@tonic-gate if (kid->op_type == OP_METHOD_NAMED
1040*0Sstevel@tonic-gate || kid->op_type == OP_METHOD)
1041*0Sstevel@tonic-gate {
1042*0Sstevel@tonic-gate UNOP *newop;
1043*0Sstevel@tonic-gate
1044*0Sstevel@tonic-gate NewOp(1101, newop, 1, UNOP);
1045*0Sstevel@tonic-gate newop->op_type = OP_RV2CV;
1046*0Sstevel@tonic-gate newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1047*0Sstevel@tonic-gate newop->op_first = Nullop;
1048*0Sstevel@tonic-gate newop->op_next = (OP*)newop;
1049*0Sstevel@tonic-gate kid->op_sibling = (OP*)newop;
1050*0Sstevel@tonic-gate newop->op_private |= OPpLVAL_INTRO;
1051*0Sstevel@tonic-gate break;
1052*0Sstevel@tonic-gate }
1053*0Sstevel@tonic-gate
1054*0Sstevel@tonic-gate if (kid->op_type != OP_RV2CV)
1055*0Sstevel@tonic-gate Perl_croak(aTHX_
1056*0Sstevel@tonic-gate "panic: unexpected lvalue entersub "
1057*0Sstevel@tonic-gate "entry via type/targ %ld:%"UVuf,
1058*0Sstevel@tonic-gate (long)kid->op_type, (UV)kid->op_targ);
1059*0Sstevel@tonic-gate kid->op_private |= OPpLVAL_INTRO;
1060*0Sstevel@tonic-gate break; /* Postpone until runtime */
1061*0Sstevel@tonic-gate }
1062*0Sstevel@tonic-gate
1063*0Sstevel@tonic-gate okid = kid;
1064*0Sstevel@tonic-gate kid = kUNOP->op_first;
1065*0Sstevel@tonic-gate if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1066*0Sstevel@tonic-gate kid = kUNOP->op_first;
1067*0Sstevel@tonic-gate if (kid->op_type == OP_NULL)
1068*0Sstevel@tonic-gate Perl_croak(aTHX_
1069*0Sstevel@tonic-gate "Unexpected constant lvalue entersub "
1070*0Sstevel@tonic-gate "entry via type/targ %ld:%"UVuf,
1071*0Sstevel@tonic-gate (long)kid->op_type, (UV)kid->op_targ);
1072*0Sstevel@tonic-gate if (kid->op_type != OP_GV) {
1073*0Sstevel@tonic-gate /* Restore RV2CV to check lvalueness */
1074*0Sstevel@tonic-gate restore_2cv:
1075*0Sstevel@tonic-gate if (kid->op_next && kid->op_next != kid) { /* Happens? */
1076*0Sstevel@tonic-gate okid->op_next = kid->op_next;
1077*0Sstevel@tonic-gate kid->op_next = okid;
1078*0Sstevel@tonic-gate }
1079*0Sstevel@tonic-gate else
1080*0Sstevel@tonic-gate okid->op_next = Nullop;
1081*0Sstevel@tonic-gate okid->op_type = OP_RV2CV;
1082*0Sstevel@tonic-gate okid->op_targ = 0;
1083*0Sstevel@tonic-gate okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1084*0Sstevel@tonic-gate okid->op_private |= OPpLVAL_INTRO;
1085*0Sstevel@tonic-gate break;
1086*0Sstevel@tonic-gate }
1087*0Sstevel@tonic-gate
1088*0Sstevel@tonic-gate cv = GvCV(kGVOP_gv);
1089*0Sstevel@tonic-gate if (!cv)
1090*0Sstevel@tonic-gate goto restore_2cv;
1091*0Sstevel@tonic-gate if (CvLVALUE(cv))
1092*0Sstevel@tonic-gate break;
1093*0Sstevel@tonic-gate }
1094*0Sstevel@tonic-gate }
1095*0Sstevel@tonic-gate /* FALL THROUGH */
1096*0Sstevel@tonic-gate default:
1097*0Sstevel@tonic-gate nomod:
1098*0Sstevel@tonic-gate /* grep, foreach, subcalls, refgen */
1099*0Sstevel@tonic-gate if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1100*0Sstevel@tonic-gate break;
1101*0Sstevel@tonic-gate yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1102*0Sstevel@tonic-gate (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1103*0Sstevel@tonic-gate ? "do block"
1104*0Sstevel@tonic-gate : (o->op_type == OP_ENTERSUB
1105*0Sstevel@tonic-gate ? "non-lvalue subroutine call"
1106*0Sstevel@tonic-gate : OP_DESC(o))),
1107*0Sstevel@tonic-gate type ? PL_op_desc[type] : "local"));
1108*0Sstevel@tonic-gate return o;
1109*0Sstevel@tonic-gate
1110*0Sstevel@tonic-gate case OP_PREINC:
1111*0Sstevel@tonic-gate case OP_PREDEC:
1112*0Sstevel@tonic-gate case OP_POW:
1113*0Sstevel@tonic-gate case OP_MULTIPLY:
1114*0Sstevel@tonic-gate case OP_DIVIDE:
1115*0Sstevel@tonic-gate case OP_MODULO:
1116*0Sstevel@tonic-gate case OP_REPEAT:
1117*0Sstevel@tonic-gate case OP_ADD:
1118*0Sstevel@tonic-gate case OP_SUBTRACT:
1119*0Sstevel@tonic-gate case OP_CONCAT:
1120*0Sstevel@tonic-gate case OP_LEFT_SHIFT:
1121*0Sstevel@tonic-gate case OP_RIGHT_SHIFT:
1122*0Sstevel@tonic-gate case OP_BIT_AND:
1123*0Sstevel@tonic-gate case OP_BIT_XOR:
1124*0Sstevel@tonic-gate case OP_BIT_OR:
1125*0Sstevel@tonic-gate case OP_I_MULTIPLY:
1126*0Sstevel@tonic-gate case OP_I_DIVIDE:
1127*0Sstevel@tonic-gate case OP_I_MODULO:
1128*0Sstevel@tonic-gate case OP_I_ADD:
1129*0Sstevel@tonic-gate case OP_I_SUBTRACT:
1130*0Sstevel@tonic-gate if (!(o->op_flags & OPf_STACKED))
1131*0Sstevel@tonic-gate goto nomod;
1132*0Sstevel@tonic-gate PL_modcount++;
1133*0Sstevel@tonic-gate break;
1134*0Sstevel@tonic-gate
1135*0Sstevel@tonic-gate case OP_COND_EXPR:
1136*0Sstevel@tonic-gate for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1137*0Sstevel@tonic-gate mod(kid, type);
1138*0Sstevel@tonic-gate break;
1139*0Sstevel@tonic-gate
1140*0Sstevel@tonic-gate case OP_RV2AV:
1141*0Sstevel@tonic-gate case OP_RV2HV:
1142*0Sstevel@tonic-gate if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1143*0Sstevel@tonic-gate PL_modcount = RETURN_UNLIMITED_NUMBER;
1144*0Sstevel@tonic-gate return o; /* Treat \(@foo) like ordinary list. */
1145*0Sstevel@tonic-gate }
1146*0Sstevel@tonic-gate /* FALL THROUGH */
1147*0Sstevel@tonic-gate case OP_RV2GV:
1148*0Sstevel@tonic-gate if (scalar_mod_type(o, type))
1149*0Sstevel@tonic-gate goto nomod;
1150*0Sstevel@tonic-gate ref(cUNOPo->op_first, o->op_type);
1151*0Sstevel@tonic-gate /* FALL THROUGH */
1152*0Sstevel@tonic-gate case OP_ASLICE:
1153*0Sstevel@tonic-gate case OP_HSLICE:
1154*0Sstevel@tonic-gate if (type == OP_LEAVESUBLV)
1155*0Sstevel@tonic-gate o->op_private |= OPpMAYBE_LVSUB;
1156*0Sstevel@tonic-gate /* FALL THROUGH */
1157*0Sstevel@tonic-gate case OP_AASSIGN:
1158*0Sstevel@tonic-gate case OP_NEXTSTATE:
1159*0Sstevel@tonic-gate case OP_DBSTATE:
1160*0Sstevel@tonic-gate PL_modcount = RETURN_UNLIMITED_NUMBER;
1161*0Sstevel@tonic-gate break;
1162*0Sstevel@tonic-gate case OP_RV2SV:
1163*0Sstevel@tonic-gate ref(cUNOPo->op_first, o->op_type);
1164*0Sstevel@tonic-gate /* FALL THROUGH */
1165*0Sstevel@tonic-gate case OP_GV:
1166*0Sstevel@tonic-gate case OP_AV2ARYLEN:
1167*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE;
1168*0Sstevel@tonic-gate case OP_SASSIGN:
1169*0Sstevel@tonic-gate case OP_ANDASSIGN:
1170*0Sstevel@tonic-gate case OP_ORASSIGN:
1171*0Sstevel@tonic-gate case OP_AELEMFAST:
1172*0Sstevel@tonic-gate /* Needed if maint gets patch 19588
1173*0Sstevel@tonic-gate localize = -1;
1174*0Sstevel@tonic-gate */
1175*0Sstevel@tonic-gate PL_modcount++;
1176*0Sstevel@tonic-gate break;
1177*0Sstevel@tonic-gate
1178*0Sstevel@tonic-gate case OP_PADAV:
1179*0Sstevel@tonic-gate case OP_PADHV:
1180*0Sstevel@tonic-gate PL_modcount = RETURN_UNLIMITED_NUMBER;
1181*0Sstevel@tonic-gate if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1182*0Sstevel@tonic-gate return o; /* Treat \(@foo) like ordinary list. */
1183*0Sstevel@tonic-gate if (scalar_mod_type(o, type))
1184*0Sstevel@tonic-gate goto nomod;
1185*0Sstevel@tonic-gate if (type == OP_LEAVESUBLV)
1186*0Sstevel@tonic-gate o->op_private |= OPpMAYBE_LVSUB;
1187*0Sstevel@tonic-gate /* FALL THROUGH */
1188*0Sstevel@tonic-gate case OP_PADSV:
1189*0Sstevel@tonic-gate PL_modcount++;
1190*0Sstevel@tonic-gate if (!type)
1191*0Sstevel@tonic-gate { /* XXX DAPM 2002.08.25 tmp assert test */
1192*0Sstevel@tonic-gate /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1193*0Sstevel@tonic-gate /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE));
1194*0Sstevel@tonic-gate
1195*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can't localize lexical variable %s",
1196*0Sstevel@tonic-gate PAD_COMPNAME_PV(o->op_targ));
1197*0Sstevel@tonic-gate }
1198*0Sstevel@tonic-gate break;
1199*0Sstevel@tonic-gate
1200*0Sstevel@tonic-gate #ifdef USE_5005THREADS
1201*0Sstevel@tonic-gate case OP_THREADSV:
1202*0Sstevel@tonic-gate PL_modcount++; /* XXX ??? */
1203*0Sstevel@tonic-gate break;
1204*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
1205*0Sstevel@tonic-gate
1206*0Sstevel@tonic-gate case OP_PUSHMARK:
1207*0Sstevel@tonic-gate break;
1208*0Sstevel@tonic-gate
1209*0Sstevel@tonic-gate case OP_KEYS:
1210*0Sstevel@tonic-gate if (type != OP_SASSIGN)
1211*0Sstevel@tonic-gate goto nomod;
1212*0Sstevel@tonic-gate goto lvalue_func;
1213*0Sstevel@tonic-gate case OP_SUBSTR:
1214*0Sstevel@tonic-gate if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1215*0Sstevel@tonic-gate goto nomod;
1216*0Sstevel@tonic-gate /* FALL THROUGH */
1217*0Sstevel@tonic-gate case OP_POS:
1218*0Sstevel@tonic-gate case OP_VEC:
1219*0Sstevel@tonic-gate if (type == OP_LEAVESUBLV)
1220*0Sstevel@tonic-gate o->op_private |= OPpMAYBE_LVSUB;
1221*0Sstevel@tonic-gate lvalue_func:
1222*0Sstevel@tonic-gate pad_free(o->op_targ);
1223*0Sstevel@tonic-gate o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1224*0Sstevel@tonic-gate assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1225*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS)
1226*0Sstevel@tonic-gate mod(cBINOPo->op_first->op_sibling, type);
1227*0Sstevel@tonic-gate break;
1228*0Sstevel@tonic-gate
1229*0Sstevel@tonic-gate case OP_AELEM:
1230*0Sstevel@tonic-gate case OP_HELEM:
1231*0Sstevel@tonic-gate ref(cBINOPo->op_first, o->op_type);
1232*0Sstevel@tonic-gate if (type == OP_ENTERSUB &&
1233*0Sstevel@tonic-gate !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1234*0Sstevel@tonic-gate o->op_private |= OPpLVAL_DEFER;
1235*0Sstevel@tonic-gate if (type == OP_LEAVESUBLV)
1236*0Sstevel@tonic-gate o->op_private |= OPpMAYBE_LVSUB;
1237*0Sstevel@tonic-gate PL_modcount++;
1238*0Sstevel@tonic-gate break;
1239*0Sstevel@tonic-gate
1240*0Sstevel@tonic-gate case OP_SCOPE:
1241*0Sstevel@tonic-gate case OP_LEAVE:
1242*0Sstevel@tonic-gate case OP_ENTER:
1243*0Sstevel@tonic-gate case OP_LINESEQ:
1244*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS)
1245*0Sstevel@tonic-gate mod(cLISTOPo->op_last, type);
1246*0Sstevel@tonic-gate break;
1247*0Sstevel@tonic-gate
1248*0Sstevel@tonic-gate case OP_NULL:
1249*0Sstevel@tonic-gate if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1250*0Sstevel@tonic-gate goto nomod;
1251*0Sstevel@tonic-gate else if (!(o->op_flags & OPf_KIDS))
1252*0Sstevel@tonic-gate break;
1253*0Sstevel@tonic-gate if (o->op_targ != OP_LIST) {
1254*0Sstevel@tonic-gate mod(cBINOPo->op_first, type);
1255*0Sstevel@tonic-gate break;
1256*0Sstevel@tonic-gate }
1257*0Sstevel@tonic-gate /* FALL THROUGH */
1258*0Sstevel@tonic-gate case OP_LIST:
1259*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1260*0Sstevel@tonic-gate mod(kid, type);
1261*0Sstevel@tonic-gate break;
1262*0Sstevel@tonic-gate
1263*0Sstevel@tonic-gate case OP_RETURN:
1264*0Sstevel@tonic-gate if (type != OP_LEAVESUBLV)
1265*0Sstevel@tonic-gate goto nomod;
1266*0Sstevel@tonic-gate break; /* mod()ing was handled by ck_return() */
1267*0Sstevel@tonic-gate }
1268*0Sstevel@tonic-gate
1269*0Sstevel@tonic-gate /* [20011101.069] File test operators interpret OPf_REF to mean that
1270*0Sstevel@tonic-gate their argument is a filehandle; thus \stat(".") should not set
1271*0Sstevel@tonic-gate it. AMS 20011102 */
1272*0Sstevel@tonic-gate if (type == OP_REFGEN &&
1273*0Sstevel@tonic-gate PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1274*0Sstevel@tonic-gate return o;
1275*0Sstevel@tonic-gate
1276*0Sstevel@tonic-gate if (type != OP_LEAVESUBLV)
1277*0Sstevel@tonic-gate o->op_flags |= OPf_MOD;
1278*0Sstevel@tonic-gate
1279*0Sstevel@tonic-gate if (type == OP_AASSIGN || type == OP_SASSIGN)
1280*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL|OPf_REF;
1281*0Sstevel@tonic-gate else if (!type) {
1282*0Sstevel@tonic-gate o->op_private |= OPpLVAL_INTRO;
1283*0Sstevel@tonic-gate o->op_flags &= ~OPf_SPECIAL;
1284*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE;
1285*0Sstevel@tonic-gate }
1286*0Sstevel@tonic-gate else if (type != OP_GREPSTART && type != OP_ENTERSUB
1287*0Sstevel@tonic-gate && type != OP_LEAVESUBLV)
1288*0Sstevel@tonic-gate o->op_flags |= OPf_REF;
1289*0Sstevel@tonic-gate return o;
1290*0Sstevel@tonic-gate }
1291*0Sstevel@tonic-gate
1292*0Sstevel@tonic-gate STATIC bool
S_scalar_mod_type(pTHX_ OP * o,I32 type)1293*0Sstevel@tonic-gate S_scalar_mod_type(pTHX_ OP *o, I32 type)
1294*0Sstevel@tonic-gate {
1295*0Sstevel@tonic-gate switch (type) {
1296*0Sstevel@tonic-gate case OP_SASSIGN:
1297*0Sstevel@tonic-gate if (o->op_type == OP_RV2GV)
1298*0Sstevel@tonic-gate return FALSE;
1299*0Sstevel@tonic-gate /* FALL THROUGH */
1300*0Sstevel@tonic-gate case OP_PREINC:
1301*0Sstevel@tonic-gate case OP_PREDEC:
1302*0Sstevel@tonic-gate case OP_POSTINC:
1303*0Sstevel@tonic-gate case OP_POSTDEC:
1304*0Sstevel@tonic-gate case OP_I_PREINC:
1305*0Sstevel@tonic-gate case OP_I_PREDEC:
1306*0Sstevel@tonic-gate case OP_I_POSTINC:
1307*0Sstevel@tonic-gate case OP_I_POSTDEC:
1308*0Sstevel@tonic-gate case OP_POW:
1309*0Sstevel@tonic-gate case OP_MULTIPLY:
1310*0Sstevel@tonic-gate case OP_DIVIDE:
1311*0Sstevel@tonic-gate case OP_MODULO:
1312*0Sstevel@tonic-gate case OP_REPEAT:
1313*0Sstevel@tonic-gate case OP_ADD:
1314*0Sstevel@tonic-gate case OP_SUBTRACT:
1315*0Sstevel@tonic-gate case OP_I_MULTIPLY:
1316*0Sstevel@tonic-gate case OP_I_DIVIDE:
1317*0Sstevel@tonic-gate case OP_I_MODULO:
1318*0Sstevel@tonic-gate case OP_I_ADD:
1319*0Sstevel@tonic-gate case OP_I_SUBTRACT:
1320*0Sstevel@tonic-gate case OP_LEFT_SHIFT:
1321*0Sstevel@tonic-gate case OP_RIGHT_SHIFT:
1322*0Sstevel@tonic-gate case OP_BIT_AND:
1323*0Sstevel@tonic-gate case OP_BIT_XOR:
1324*0Sstevel@tonic-gate case OP_BIT_OR:
1325*0Sstevel@tonic-gate case OP_CONCAT:
1326*0Sstevel@tonic-gate case OP_SUBST:
1327*0Sstevel@tonic-gate case OP_TRANS:
1328*0Sstevel@tonic-gate case OP_READ:
1329*0Sstevel@tonic-gate case OP_SYSREAD:
1330*0Sstevel@tonic-gate case OP_RECV:
1331*0Sstevel@tonic-gate case OP_ANDASSIGN:
1332*0Sstevel@tonic-gate case OP_ORASSIGN:
1333*0Sstevel@tonic-gate return TRUE;
1334*0Sstevel@tonic-gate default:
1335*0Sstevel@tonic-gate return FALSE;
1336*0Sstevel@tonic-gate }
1337*0Sstevel@tonic-gate }
1338*0Sstevel@tonic-gate
1339*0Sstevel@tonic-gate STATIC bool
S_is_handle_constructor(pTHX_ OP * o,I32 argnum)1340*0Sstevel@tonic-gate S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1341*0Sstevel@tonic-gate {
1342*0Sstevel@tonic-gate switch (o->op_type) {
1343*0Sstevel@tonic-gate case OP_PIPE_OP:
1344*0Sstevel@tonic-gate case OP_SOCKPAIR:
1345*0Sstevel@tonic-gate if (argnum == 2)
1346*0Sstevel@tonic-gate return TRUE;
1347*0Sstevel@tonic-gate /* FALL THROUGH */
1348*0Sstevel@tonic-gate case OP_SYSOPEN:
1349*0Sstevel@tonic-gate case OP_OPEN:
1350*0Sstevel@tonic-gate case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1351*0Sstevel@tonic-gate case OP_SOCKET:
1352*0Sstevel@tonic-gate case OP_OPEN_DIR:
1353*0Sstevel@tonic-gate case OP_ACCEPT:
1354*0Sstevel@tonic-gate if (argnum == 1)
1355*0Sstevel@tonic-gate return TRUE;
1356*0Sstevel@tonic-gate /* FALL THROUGH */
1357*0Sstevel@tonic-gate default:
1358*0Sstevel@tonic-gate return FALSE;
1359*0Sstevel@tonic-gate }
1360*0Sstevel@tonic-gate }
1361*0Sstevel@tonic-gate
1362*0Sstevel@tonic-gate OP *
Perl_refkids(pTHX_ OP * o,I32 type)1363*0Sstevel@tonic-gate Perl_refkids(pTHX_ OP *o, I32 type)
1364*0Sstevel@tonic-gate {
1365*0Sstevel@tonic-gate OP *kid;
1366*0Sstevel@tonic-gate if (o && o->op_flags & OPf_KIDS) {
1367*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1368*0Sstevel@tonic-gate ref(kid, type);
1369*0Sstevel@tonic-gate }
1370*0Sstevel@tonic-gate return o;
1371*0Sstevel@tonic-gate }
1372*0Sstevel@tonic-gate
1373*0Sstevel@tonic-gate OP *
Perl_ref(pTHX_ OP * o,I32 type)1374*0Sstevel@tonic-gate Perl_ref(pTHX_ OP *o, I32 type)
1375*0Sstevel@tonic-gate {
1376*0Sstevel@tonic-gate OP *kid;
1377*0Sstevel@tonic-gate
1378*0Sstevel@tonic-gate if (!o || PL_error_count)
1379*0Sstevel@tonic-gate return o;
1380*0Sstevel@tonic-gate
1381*0Sstevel@tonic-gate switch (o->op_type) {
1382*0Sstevel@tonic-gate case OP_ENTERSUB:
1383*0Sstevel@tonic-gate if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1384*0Sstevel@tonic-gate !(o->op_flags & OPf_STACKED)) {
1385*0Sstevel@tonic-gate o->op_type = OP_RV2CV; /* entersub => rv2cv */
1386*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1387*0Sstevel@tonic-gate assert(cUNOPo->op_first->op_type == OP_NULL);
1388*0Sstevel@tonic-gate op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1389*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL;
1390*0Sstevel@tonic-gate }
1391*0Sstevel@tonic-gate break;
1392*0Sstevel@tonic-gate
1393*0Sstevel@tonic-gate case OP_COND_EXPR:
1394*0Sstevel@tonic-gate for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1395*0Sstevel@tonic-gate ref(kid, type);
1396*0Sstevel@tonic-gate break;
1397*0Sstevel@tonic-gate case OP_RV2SV:
1398*0Sstevel@tonic-gate if (type == OP_DEFINED)
1399*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL; /* don't create GV */
1400*0Sstevel@tonic-gate ref(cUNOPo->op_first, o->op_type);
1401*0Sstevel@tonic-gate /* FALL THROUGH */
1402*0Sstevel@tonic-gate case OP_PADSV:
1403*0Sstevel@tonic-gate if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1404*0Sstevel@tonic-gate o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1405*0Sstevel@tonic-gate : type == OP_RV2HV ? OPpDEREF_HV
1406*0Sstevel@tonic-gate : OPpDEREF_SV);
1407*0Sstevel@tonic-gate o->op_flags |= OPf_MOD;
1408*0Sstevel@tonic-gate }
1409*0Sstevel@tonic-gate break;
1410*0Sstevel@tonic-gate
1411*0Sstevel@tonic-gate case OP_THREADSV:
1412*0Sstevel@tonic-gate o->op_flags |= OPf_MOD; /* XXX ??? */
1413*0Sstevel@tonic-gate break;
1414*0Sstevel@tonic-gate
1415*0Sstevel@tonic-gate case OP_RV2AV:
1416*0Sstevel@tonic-gate case OP_RV2HV:
1417*0Sstevel@tonic-gate o->op_flags |= OPf_REF;
1418*0Sstevel@tonic-gate /* FALL THROUGH */
1419*0Sstevel@tonic-gate case OP_RV2GV:
1420*0Sstevel@tonic-gate if (type == OP_DEFINED)
1421*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL; /* don't create GV */
1422*0Sstevel@tonic-gate ref(cUNOPo->op_first, o->op_type);
1423*0Sstevel@tonic-gate break;
1424*0Sstevel@tonic-gate
1425*0Sstevel@tonic-gate case OP_PADAV:
1426*0Sstevel@tonic-gate case OP_PADHV:
1427*0Sstevel@tonic-gate o->op_flags |= OPf_REF;
1428*0Sstevel@tonic-gate break;
1429*0Sstevel@tonic-gate
1430*0Sstevel@tonic-gate case OP_SCALAR:
1431*0Sstevel@tonic-gate case OP_NULL:
1432*0Sstevel@tonic-gate if (!(o->op_flags & OPf_KIDS))
1433*0Sstevel@tonic-gate break;
1434*0Sstevel@tonic-gate ref(cBINOPo->op_first, type);
1435*0Sstevel@tonic-gate break;
1436*0Sstevel@tonic-gate case OP_AELEM:
1437*0Sstevel@tonic-gate case OP_HELEM:
1438*0Sstevel@tonic-gate ref(cBINOPo->op_first, o->op_type);
1439*0Sstevel@tonic-gate if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1440*0Sstevel@tonic-gate o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1441*0Sstevel@tonic-gate : type == OP_RV2HV ? OPpDEREF_HV
1442*0Sstevel@tonic-gate : OPpDEREF_SV);
1443*0Sstevel@tonic-gate o->op_flags |= OPf_MOD;
1444*0Sstevel@tonic-gate }
1445*0Sstevel@tonic-gate break;
1446*0Sstevel@tonic-gate
1447*0Sstevel@tonic-gate case OP_SCOPE:
1448*0Sstevel@tonic-gate case OP_LEAVE:
1449*0Sstevel@tonic-gate case OP_ENTER:
1450*0Sstevel@tonic-gate case OP_LIST:
1451*0Sstevel@tonic-gate if (!(o->op_flags & OPf_KIDS))
1452*0Sstevel@tonic-gate break;
1453*0Sstevel@tonic-gate ref(cLISTOPo->op_last, type);
1454*0Sstevel@tonic-gate break;
1455*0Sstevel@tonic-gate default:
1456*0Sstevel@tonic-gate break;
1457*0Sstevel@tonic-gate }
1458*0Sstevel@tonic-gate return scalar(o);
1459*0Sstevel@tonic-gate
1460*0Sstevel@tonic-gate }
1461*0Sstevel@tonic-gate
1462*0Sstevel@tonic-gate STATIC OP *
S_dup_attrlist(pTHX_ OP * o)1463*0Sstevel@tonic-gate S_dup_attrlist(pTHX_ OP *o)
1464*0Sstevel@tonic-gate {
1465*0Sstevel@tonic-gate OP *rop = Nullop;
1466*0Sstevel@tonic-gate
1467*0Sstevel@tonic-gate /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1468*0Sstevel@tonic-gate * where the first kid is OP_PUSHMARK and the remaining ones
1469*0Sstevel@tonic-gate * are OP_CONST. We need to push the OP_CONST values.
1470*0Sstevel@tonic-gate */
1471*0Sstevel@tonic-gate if (o->op_type == OP_CONST)
1472*0Sstevel@tonic-gate rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1473*0Sstevel@tonic-gate else {
1474*0Sstevel@tonic-gate assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1475*0Sstevel@tonic-gate for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1476*0Sstevel@tonic-gate if (o->op_type == OP_CONST)
1477*0Sstevel@tonic-gate rop = append_elem(OP_LIST, rop,
1478*0Sstevel@tonic-gate newSVOP(OP_CONST, o->op_flags,
1479*0Sstevel@tonic-gate SvREFCNT_inc(cSVOPo->op_sv)));
1480*0Sstevel@tonic-gate }
1481*0Sstevel@tonic-gate }
1482*0Sstevel@tonic-gate return rop;
1483*0Sstevel@tonic-gate }
1484*0Sstevel@tonic-gate
1485*0Sstevel@tonic-gate STATIC void
S_apply_attrs(pTHX_ HV * stash,SV * target,OP * attrs,bool for_my)1486*0Sstevel@tonic-gate S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1487*0Sstevel@tonic-gate {
1488*0Sstevel@tonic-gate SV *stashsv;
1489*0Sstevel@tonic-gate
1490*0Sstevel@tonic-gate /* fake up C<use attributes $pkg,$rv,@attrs> */
1491*0Sstevel@tonic-gate ENTER; /* need to protect against side-effects of 'use' */
1492*0Sstevel@tonic-gate SAVEINT(PL_expect);
1493*0Sstevel@tonic-gate if (stash)
1494*0Sstevel@tonic-gate stashsv = newSVpv(HvNAME(stash), 0);
1495*0Sstevel@tonic-gate else
1496*0Sstevel@tonic-gate stashsv = &PL_sv_no;
1497*0Sstevel@tonic-gate
1498*0Sstevel@tonic-gate #define ATTRSMODULE "attributes"
1499*0Sstevel@tonic-gate #define ATTRSMODULE_PM "attributes.pm"
1500*0Sstevel@tonic-gate
1501*0Sstevel@tonic-gate if (for_my) {
1502*0Sstevel@tonic-gate SV **svp;
1503*0Sstevel@tonic-gate /* Don't force the C<use> if we don't need it. */
1504*0Sstevel@tonic-gate svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1505*0Sstevel@tonic-gate sizeof(ATTRSMODULE_PM)-1, 0);
1506*0Sstevel@tonic-gate if (svp && *svp != &PL_sv_undef)
1507*0Sstevel@tonic-gate ; /* already in %INC */
1508*0Sstevel@tonic-gate else
1509*0Sstevel@tonic-gate Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1510*0Sstevel@tonic-gate newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1511*0Sstevel@tonic-gate Nullsv);
1512*0Sstevel@tonic-gate }
1513*0Sstevel@tonic-gate else {
1514*0Sstevel@tonic-gate Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1515*0Sstevel@tonic-gate newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1516*0Sstevel@tonic-gate Nullsv,
1517*0Sstevel@tonic-gate prepend_elem(OP_LIST,
1518*0Sstevel@tonic-gate newSVOP(OP_CONST, 0, stashsv),
1519*0Sstevel@tonic-gate prepend_elem(OP_LIST,
1520*0Sstevel@tonic-gate newSVOP(OP_CONST, 0,
1521*0Sstevel@tonic-gate newRV(target)),
1522*0Sstevel@tonic-gate dup_attrlist(attrs))));
1523*0Sstevel@tonic-gate }
1524*0Sstevel@tonic-gate LEAVE;
1525*0Sstevel@tonic-gate }
1526*0Sstevel@tonic-gate
1527*0Sstevel@tonic-gate STATIC void
S_apply_attrs_my(pTHX_ HV * stash,OP * target,OP * attrs,OP ** imopsp)1528*0Sstevel@tonic-gate S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1529*0Sstevel@tonic-gate {
1530*0Sstevel@tonic-gate OP *pack, *imop, *arg;
1531*0Sstevel@tonic-gate SV *meth, *stashsv;
1532*0Sstevel@tonic-gate
1533*0Sstevel@tonic-gate if (!attrs)
1534*0Sstevel@tonic-gate return;
1535*0Sstevel@tonic-gate
1536*0Sstevel@tonic-gate assert(target->op_type == OP_PADSV ||
1537*0Sstevel@tonic-gate target->op_type == OP_PADHV ||
1538*0Sstevel@tonic-gate target->op_type == OP_PADAV);
1539*0Sstevel@tonic-gate
1540*0Sstevel@tonic-gate /* Ensure that attributes.pm is loaded. */
1541*0Sstevel@tonic-gate apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1542*0Sstevel@tonic-gate
1543*0Sstevel@tonic-gate /* Need package name for method call. */
1544*0Sstevel@tonic-gate pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1545*0Sstevel@tonic-gate
1546*0Sstevel@tonic-gate /* Build up the real arg-list. */
1547*0Sstevel@tonic-gate if (stash)
1548*0Sstevel@tonic-gate stashsv = newSVpv(HvNAME(stash), 0);
1549*0Sstevel@tonic-gate else
1550*0Sstevel@tonic-gate stashsv = &PL_sv_no;
1551*0Sstevel@tonic-gate arg = newOP(OP_PADSV, 0);
1552*0Sstevel@tonic-gate arg->op_targ = target->op_targ;
1553*0Sstevel@tonic-gate arg = prepend_elem(OP_LIST,
1554*0Sstevel@tonic-gate newSVOP(OP_CONST, 0, stashsv),
1555*0Sstevel@tonic-gate prepend_elem(OP_LIST,
1556*0Sstevel@tonic-gate newUNOP(OP_REFGEN, 0,
1557*0Sstevel@tonic-gate mod(arg, OP_REFGEN)),
1558*0Sstevel@tonic-gate dup_attrlist(attrs)));
1559*0Sstevel@tonic-gate
1560*0Sstevel@tonic-gate /* Fake up a method call to import */
1561*0Sstevel@tonic-gate meth = newSVpvn("import", 6);
1562*0Sstevel@tonic-gate (void)SvUPGRADE(meth, SVt_PVIV);
1563*0Sstevel@tonic-gate (void)SvIOK_on(meth);
1564*0Sstevel@tonic-gate PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
1565*0Sstevel@tonic-gate imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1566*0Sstevel@tonic-gate append_elem(OP_LIST,
1567*0Sstevel@tonic-gate prepend_elem(OP_LIST, pack, list(arg)),
1568*0Sstevel@tonic-gate newSVOP(OP_METHOD_NAMED, 0, meth)));
1569*0Sstevel@tonic-gate imop->op_private |= OPpENTERSUB_NOMOD;
1570*0Sstevel@tonic-gate
1571*0Sstevel@tonic-gate /* Combine the ops. */
1572*0Sstevel@tonic-gate *imopsp = append_elem(OP_LIST, *imopsp, imop);
1573*0Sstevel@tonic-gate }
1574*0Sstevel@tonic-gate
1575*0Sstevel@tonic-gate /*
1576*0Sstevel@tonic-gate =notfor apidoc apply_attrs_string
1577*0Sstevel@tonic-gate
1578*0Sstevel@tonic-gate Attempts to apply a list of attributes specified by the C<attrstr> and
1579*0Sstevel@tonic-gate C<len> arguments to the subroutine identified by the C<cv> argument which
1580*0Sstevel@tonic-gate is expected to be associated with the package identified by the C<stashpv>
1581*0Sstevel@tonic-gate argument (see L<attributes>). It gets this wrong, though, in that it
1582*0Sstevel@tonic-gate does not correctly identify the boundaries of the individual attribute
1583*0Sstevel@tonic-gate specifications within C<attrstr>. This is not really intended for the
1584*0Sstevel@tonic-gate public API, but has to be listed here for systems such as AIX which
1585*0Sstevel@tonic-gate need an explicit export list for symbols. (It's called from XS code
1586*0Sstevel@tonic-gate in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1587*0Sstevel@tonic-gate to respect attribute syntax properly would be welcome.
1588*0Sstevel@tonic-gate
1589*0Sstevel@tonic-gate =cut
1590*0Sstevel@tonic-gate */
1591*0Sstevel@tonic-gate
1592*0Sstevel@tonic-gate void
Perl_apply_attrs_string(pTHX_ char * stashpv,CV * cv,char * attrstr,STRLEN len)1593*0Sstevel@tonic-gate Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1594*0Sstevel@tonic-gate char *attrstr, STRLEN len)
1595*0Sstevel@tonic-gate {
1596*0Sstevel@tonic-gate OP *attrs = Nullop;
1597*0Sstevel@tonic-gate
1598*0Sstevel@tonic-gate if (!len) {
1599*0Sstevel@tonic-gate len = strlen(attrstr);
1600*0Sstevel@tonic-gate }
1601*0Sstevel@tonic-gate
1602*0Sstevel@tonic-gate while (len) {
1603*0Sstevel@tonic-gate for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1604*0Sstevel@tonic-gate if (len) {
1605*0Sstevel@tonic-gate char *sstr = attrstr;
1606*0Sstevel@tonic-gate for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1607*0Sstevel@tonic-gate attrs = append_elem(OP_LIST, attrs,
1608*0Sstevel@tonic-gate newSVOP(OP_CONST, 0,
1609*0Sstevel@tonic-gate newSVpvn(sstr, attrstr-sstr)));
1610*0Sstevel@tonic-gate }
1611*0Sstevel@tonic-gate }
1612*0Sstevel@tonic-gate
1613*0Sstevel@tonic-gate Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1614*0Sstevel@tonic-gate newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1615*0Sstevel@tonic-gate Nullsv, prepend_elem(OP_LIST,
1616*0Sstevel@tonic-gate newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1617*0Sstevel@tonic-gate prepend_elem(OP_LIST,
1618*0Sstevel@tonic-gate newSVOP(OP_CONST, 0,
1619*0Sstevel@tonic-gate newRV((SV*)cv)),
1620*0Sstevel@tonic-gate attrs)));
1621*0Sstevel@tonic-gate }
1622*0Sstevel@tonic-gate
1623*0Sstevel@tonic-gate STATIC OP *
S_my_kid(pTHX_ OP * o,OP * attrs,OP ** imopsp)1624*0Sstevel@tonic-gate S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1625*0Sstevel@tonic-gate {
1626*0Sstevel@tonic-gate OP *kid;
1627*0Sstevel@tonic-gate I32 type;
1628*0Sstevel@tonic-gate
1629*0Sstevel@tonic-gate if (!o || PL_error_count)
1630*0Sstevel@tonic-gate return o;
1631*0Sstevel@tonic-gate
1632*0Sstevel@tonic-gate type = o->op_type;
1633*0Sstevel@tonic-gate if (type == OP_LIST) {
1634*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1635*0Sstevel@tonic-gate my_kid(kid, attrs, imopsp);
1636*0Sstevel@tonic-gate } else if (type == OP_UNDEF) {
1637*0Sstevel@tonic-gate return o;
1638*0Sstevel@tonic-gate } else if (type == OP_RV2SV || /* "our" declaration */
1639*0Sstevel@tonic-gate type == OP_RV2AV ||
1640*0Sstevel@tonic-gate type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1641*0Sstevel@tonic-gate if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1642*0Sstevel@tonic-gate yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1643*0Sstevel@tonic-gate OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1644*0Sstevel@tonic-gate } else if (attrs) {
1645*0Sstevel@tonic-gate GV *gv = cGVOPx_gv(cUNOPo->op_first);
1646*0Sstevel@tonic-gate PL_in_my = FALSE;
1647*0Sstevel@tonic-gate PL_in_my_stash = Nullhv;
1648*0Sstevel@tonic-gate apply_attrs(GvSTASH(gv),
1649*0Sstevel@tonic-gate (type == OP_RV2SV ? GvSV(gv) :
1650*0Sstevel@tonic-gate type == OP_RV2AV ? (SV*)GvAV(gv) :
1651*0Sstevel@tonic-gate type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1652*0Sstevel@tonic-gate attrs, FALSE);
1653*0Sstevel@tonic-gate }
1654*0Sstevel@tonic-gate o->op_private |= OPpOUR_INTRO;
1655*0Sstevel@tonic-gate return o;
1656*0Sstevel@tonic-gate }
1657*0Sstevel@tonic-gate else if (type != OP_PADSV &&
1658*0Sstevel@tonic-gate type != OP_PADAV &&
1659*0Sstevel@tonic-gate type != OP_PADHV &&
1660*0Sstevel@tonic-gate type != OP_PUSHMARK)
1661*0Sstevel@tonic-gate {
1662*0Sstevel@tonic-gate yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1663*0Sstevel@tonic-gate OP_DESC(o),
1664*0Sstevel@tonic-gate PL_in_my == KEY_our ? "our" : "my"));
1665*0Sstevel@tonic-gate return o;
1666*0Sstevel@tonic-gate }
1667*0Sstevel@tonic-gate else if (attrs && type != OP_PUSHMARK) {
1668*0Sstevel@tonic-gate HV *stash;
1669*0Sstevel@tonic-gate
1670*0Sstevel@tonic-gate PL_in_my = FALSE;
1671*0Sstevel@tonic-gate PL_in_my_stash = Nullhv;
1672*0Sstevel@tonic-gate
1673*0Sstevel@tonic-gate /* check for C<my Dog $spot> when deciding package */
1674*0Sstevel@tonic-gate stash = PAD_COMPNAME_TYPE(o->op_targ);
1675*0Sstevel@tonic-gate if (!stash)
1676*0Sstevel@tonic-gate stash = PL_curstash;
1677*0Sstevel@tonic-gate apply_attrs_my(stash, o, attrs, imopsp);
1678*0Sstevel@tonic-gate }
1679*0Sstevel@tonic-gate o->op_flags |= OPf_MOD;
1680*0Sstevel@tonic-gate o->op_private |= OPpLVAL_INTRO;
1681*0Sstevel@tonic-gate return o;
1682*0Sstevel@tonic-gate }
1683*0Sstevel@tonic-gate
1684*0Sstevel@tonic-gate OP *
Perl_my_attrs(pTHX_ OP * o,OP * attrs)1685*0Sstevel@tonic-gate Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1686*0Sstevel@tonic-gate {
1687*0Sstevel@tonic-gate OP *rops = Nullop;
1688*0Sstevel@tonic-gate int maybe_scalar = 0;
1689*0Sstevel@tonic-gate
1690*0Sstevel@tonic-gate /* [perl #17376]: this appears to be premature, and results in code such as
1691*0Sstevel@tonic-gate C< our(%x); > executing in list mode rather than void mode */
1692*0Sstevel@tonic-gate #if 0
1693*0Sstevel@tonic-gate if (o->op_flags & OPf_PARENS)
1694*0Sstevel@tonic-gate list(o);
1695*0Sstevel@tonic-gate else
1696*0Sstevel@tonic-gate maybe_scalar = 1;
1697*0Sstevel@tonic-gate #else
1698*0Sstevel@tonic-gate maybe_scalar = 1;
1699*0Sstevel@tonic-gate #endif
1700*0Sstevel@tonic-gate if (attrs)
1701*0Sstevel@tonic-gate SAVEFREEOP(attrs);
1702*0Sstevel@tonic-gate o = my_kid(o, attrs, &rops);
1703*0Sstevel@tonic-gate if (rops) {
1704*0Sstevel@tonic-gate if (maybe_scalar && o->op_type == OP_PADSV) {
1705*0Sstevel@tonic-gate o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1706*0Sstevel@tonic-gate o->op_private |= OPpLVAL_INTRO;
1707*0Sstevel@tonic-gate }
1708*0Sstevel@tonic-gate else
1709*0Sstevel@tonic-gate o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1710*0Sstevel@tonic-gate }
1711*0Sstevel@tonic-gate PL_in_my = FALSE;
1712*0Sstevel@tonic-gate PL_in_my_stash = Nullhv;
1713*0Sstevel@tonic-gate return o;
1714*0Sstevel@tonic-gate }
1715*0Sstevel@tonic-gate
1716*0Sstevel@tonic-gate OP *
Perl_my(pTHX_ OP * o)1717*0Sstevel@tonic-gate Perl_my(pTHX_ OP *o)
1718*0Sstevel@tonic-gate {
1719*0Sstevel@tonic-gate return my_attrs(o, Nullop);
1720*0Sstevel@tonic-gate }
1721*0Sstevel@tonic-gate
1722*0Sstevel@tonic-gate OP *
Perl_sawparens(pTHX_ OP * o)1723*0Sstevel@tonic-gate Perl_sawparens(pTHX_ OP *o)
1724*0Sstevel@tonic-gate {
1725*0Sstevel@tonic-gate if (o)
1726*0Sstevel@tonic-gate o->op_flags |= OPf_PARENS;
1727*0Sstevel@tonic-gate return o;
1728*0Sstevel@tonic-gate }
1729*0Sstevel@tonic-gate
1730*0Sstevel@tonic-gate OP *
Perl_bind_match(pTHX_ I32 type,OP * left,OP * right)1731*0Sstevel@tonic-gate Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1732*0Sstevel@tonic-gate {
1733*0Sstevel@tonic-gate OP *o;
1734*0Sstevel@tonic-gate
1735*0Sstevel@tonic-gate if (ckWARN(WARN_MISC) &&
1736*0Sstevel@tonic-gate (left->op_type == OP_RV2AV ||
1737*0Sstevel@tonic-gate left->op_type == OP_RV2HV ||
1738*0Sstevel@tonic-gate left->op_type == OP_PADAV ||
1739*0Sstevel@tonic-gate left->op_type == OP_PADHV)) {
1740*0Sstevel@tonic-gate char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
1741*0Sstevel@tonic-gate right->op_type == OP_TRANS)
1742*0Sstevel@tonic-gate ? right->op_type : OP_MATCH];
1743*0Sstevel@tonic-gate const char *sample = ((left->op_type == OP_RV2AV ||
1744*0Sstevel@tonic-gate left->op_type == OP_PADAV)
1745*0Sstevel@tonic-gate ? "@array" : "%hash");
1746*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_MISC),
1747*0Sstevel@tonic-gate "Applying %s to %s will act on scalar(%s)",
1748*0Sstevel@tonic-gate desc, sample, sample);
1749*0Sstevel@tonic-gate }
1750*0Sstevel@tonic-gate
1751*0Sstevel@tonic-gate if (right->op_type == OP_CONST &&
1752*0Sstevel@tonic-gate cSVOPx(right)->op_private & OPpCONST_BARE &&
1753*0Sstevel@tonic-gate cSVOPx(right)->op_private & OPpCONST_STRICT)
1754*0Sstevel@tonic-gate {
1755*0Sstevel@tonic-gate no_bareword_allowed(right);
1756*0Sstevel@tonic-gate }
1757*0Sstevel@tonic-gate
1758*0Sstevel@tonic-gate if (!(right->op_flags & OPf_STACKED) &&
1759*0Sstevel@tonic-gate (right->op_type == OP_MATCH ||
1760*0Sstevel@tonic-gate right->op_type == OP_SUBST ||
1761*0Sstevel@tonic-gate right->op_type == OP_TRANS)) {
1762*0Sstevel@tonic-gate right->op_flags |= OPf_STACKED;
1763*0Sstevel@tonic-gate if (right->op_type != OP_MATCH &&
1764*0Sstevel@tonic-gate ! (right->op_type == OP_TRANS &&
1765*0Sstevel@tonic-gate right->op_private & OPpTRANS_IDENTICAL))
1766*0Sstevel@tonic-gate left = mod(left, right->op_type);
1767*0Sstevel@tonic-gate if (right->op_type == OP_TRANS)
1768*0Sstevel@tonic-gate o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1769*0Sstevel@tonic-gate else
1770*0Sstevel@tonic-gate o = prepend_elem(right->op_type, scalar(left), right);
1771*0Sstevel@tonic-gate if (type == OP_NOT)
1772*0Sstevel@tonic-gate return newUNOP(OP_NOT, 0, scalar(o));
1773*0Sstevel@tonic-gate return o;
1774*0Sstevel@tonic-gate }
1775*0Sstevel@tonic-gate else
1776*0Sstevel@tonic-gate return bind_match(type, left,
1777*0Sstevel@tonic-gate pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1778*0Sstevel@tonic-gate }
1779*0Sstevel@tonic-gate
1780*0Sstevel@tonic-gate OP *
Perl_invert(pTHX_ OP * o)1781*0Sstevel@tonic-gate Perl_invert(pTHX_ OP *o)
1782*0Sstevel@tonic-gate {
1783*0Sstevel@tonic-gate if (!o)
1784*0Sstevel@tonic-gate return o;
1785*0Sstevel@tonic-gate /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1786*0Sstevel@tonic-gate return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1787*0Sstevel@tonic-gate }
1788*0Sstevel@tonic-gate
1789*0Sstevel@tonic-gate OP *
Perl_scope(pTHX_ OP * o)1790*0Sstevel@tonic-gate Perl_scope(pTHX_ OP *o)
1791*0Sstevel@tonic-gate {
1792*0Sstevel@tonic-gate if (o) {
1793*0Sstevel@tonic-gate if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1794*0Sstevel@tonic-gate o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1795*0Sstevel@tonic-gate o->op_type = OP_LEAVE;
1796*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1797*0Sstevel@tonic-gate }
1798*0Sstevel@tonic-gate else if (o->op_type == OP_LINESEQ) {
1799*0Sstevel@tonic-gate OP *kid;
1800*0Sstevel@tonic-gate o->op_type = OP_SCOPE;
1801*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1802*0Sstevel@tonic-gate kid = ((LISTOP*)o)->op_first;
1803*0Sstevel@tonic-gate if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
1804*0Sstevel@tonic-gate op_null(kid);
1805*0Sstevel@tonic-gate }
1806*0Sstevel@tonic-gate else
1807*0Sstevel@tonic-gate o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1808*0Sstevel@tonic-gate }
1809*0Sstevel@tonic-gate return o;
1810*0Sstevel@tonic-gate }
1811*0Sstevel@tonic-gate
1812*0Sstevel@tonic-gate /* XXX kept for BINCOMPAT only */
1813*0Sstevel@tonic-gate void
Perl_save_hints(pTHX)1814*0Sstevel@tonic-gate Perl_save_hints(pTHX)
1815*0Sstevel@tonic-gate {
1816*0Sstevel@tonic-gate Perl_croak(aTHX_ "internal error: obsolete function save_hints() called");
1817*0Sstevel@tonic-gate }
1818*0Sstevel@tonic-gate
1819*0Sstevel@tonic-gate int
Perl_block_start(pTHX_ int full)1820*0Sstevel@tonic-gate Perl_block_start(pTHX_ int full)
1821*0Sstevel@tonic-gate {
1822*0Sstevel@tonic-gate int retval = PL_savestack_ix;
1823*0Sstevel@tonic-gate /* If there were syntax errors, don't try to start a block */
1824*0Sstevel@tonic-gate if (PL_yynerrs) return retval;
1825*0Sstevel@tonic-gate
1826*0Sstevel@tonic-gate pad_block_start(full);
1827*0Sstevel@tonic-gate SAVEHINTS();
1828*0Sstevel@tonic-gate PL_hints &= ~HINT_BLOCK_SCOPE;
1829*0Sstevel@tonic-gate SAVESPTR(PL_compiling.cop_warnings);
1830*0Sstevel@tonic-gate if (! specialWARN(PL_compiling.cop_warnings)) {
1831*0Sstevel@tonic-gate PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1832*0Sstevel@tonic-gate SAVEFREESV(PL_compiling.cop_warnings) ;
1833*0Sstevel@tonic-gate }
1834*0Sstevel@tonic-gate SAVESPTR(PL_compiling.cop_io);
1835*0Sstevel@tonic-gate if (! specialCopIO(PL_compiling.cop_io)) {
1836*0Sstevel@tonic-gate PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1837*0Sstevel@tonic-gate SAVEFREESV(PL_compiling.cop_io) ;
1838*0Sstevel@tonic-gate }
1839*0Sstevel@tonic-gate return retval;
1840*0Sstevel@tonic-gate }
1841*0Sstevel@tonic-gate
1842*0Sstevel@tonic-gate OP*
Perl_block_end(pTHX_ I32 floor,OP * seq)1843*0Sstevel@tonic-gate Perl_block_end(pTHX_ I32 floor, OP *seq)
1844*0Sstevel@tonic-gate {
1845*0Sstevel@tonic-gate int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1846*0Sstevel@tonic-gate OP* retval = scalarseq(seq);
1847*0Sstevel@tonic-gate /* If there were syntax errors, don't try to close a block */
1848*0Sstevel@tonic-gate if (PL_yynerrs) return retval;
1849*0Sstevel@tonic-gate LEAVE_SCOPE(floor);
1850*0Sstevel@tonic-gate PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1851*0Sstevel@tonic-gate if (needblockscope)
1852*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1853*0Sstevel@tonic-gate pad_leavemy();
1854*0Sstevel@tonic-gate return retval;
1855*0Sstevel@tonic-gate }
1856*0Sstevel@tonic-gate
1857*0Sstevel@tonic-gate STATIC OP *
S_newDEFSVOP(pTHX)1858*0Sstevel@tonic-gate S_newDEFSVOP(pTHX)
1859*0Sstevel@tonic-gate {
1860*0Sstevel@tonic-gate #ifdef USE_5005THREADS
1861*0Sstevel@tonic-gate OP *o = newOP(OP_THREADSV, 0);
1862*0Sstevel@tonic-gate o->op_targ = find_threadsv("_");
1863*0Sstevel@tonic-gate return o;
1864*0Sstevel@tonic-gate #else
1865*0Sstevel@tonic-gate return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1866*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
1867*0Sstevel@tonic-gate }
1868*0Sstevel@tonic-gate
1869*0Sstevel@tonic-gate void
Perl_newPROG(pTHX_ OP * o)1870*0Sstevel@tonic-gate Perl_newPROG(pTHX_ OP *o)
1871*0Sstevel@tonic-gate {
1872*0Sstevel@tonic-gate if (PL_in_eval) {
1873*0Sstevel@tonic-gate if (PL_eval_root)
1874*0Sstevel@tonic-gate return;
1875*0Sstevel@tonic-gate PL_eval_root = newUNOP(OP_LEAVEEVAL,
1876*0Sstevel@tonic-gate ((PL_in_eval & EVAL_KEEPERR)
1877*0Sstevel@tonic-gate ? OPf_SPECIAL : 0), o);
1878*0Sstevel@tonic-gate PL_eval_start = linklist(PL_eval_root);
1879*0Sstevel@tonic-gate PL_eval_root->op_private |= OPpREFCOUNTED;
1880*0Sstevel@tonic-gate OpREFCNT_set(PL_eval_root, 1);
1881*0Sstevel@tonic-gate PL_eval_root->op_next = 0;
1882*0Sstevel@tonic-gate CALL_PEEP(PL_eval_start);
1883*0Sstevel@tonic-gate }
1884*0Sstevel@tonic-gate else {
1885*0Sstevel@tonic-gate if (o->op_type == OP_STUB) {
1886*0Sstevel@tonic-gate PL_comppad_name = 0;
1887*0Sstevel@tonic-gate PL_compcv = 0;
1888*0Sstevel@tonic-gate FreeOp(o);
1889*0Sstevel@tonic-gate return;
1890*0Sstevel@tonic-gate }
1891*0Sstevel@tonic-gate PL_main_root = scope(sawparens(scalarvoid(o)));
1892*0Sstevel@tonic-gate PL_curcop = &PL_compiling;
1893*0Sstevel@tonic-gate PL_main_start = LINKLIST(PL_main_root);
1894*0Sstevel@tonic-gate PL_main_root->op_private |= OPpREFCOUNTED;
1895*0Sstevel@tonic-gate OpREFCNT_set(PL_main_root, 1);
1896*0Sstevel@tonic-gate PL_main_root->op_next = 0;
1897*0Sstevel@tonic-gate CALL_PEEP(PL_main_start);
1898*0Sstevel@tonic-gate PL_compcv = 0;
1899*0Sstevel@tonic-gate
1900*0Sstevel@tonic-gate /* Register with debugger */
1901*0Sstevel@tonic-gate if (PERLDB_INTER) {
1902*0Sstevel@tonic-gate CV *cv = get_cv("DB::postponed", FALSE);
1903*0Sstevel@tonic-gate if (cv) {
1904*0Sstevel@tonic-gate dSP;
1905*0Sstevel@tonic-gate PUSHMARK(SP);
1906*0Sstevel@tonic-gate XPUSHs((SV*)CopFILEGV(&PL_compiling));
1907*0Sstevel@tonic-gate PUTBACK;
1908*0Sstevel@tonic-gate call_sv((SV*)cv, G_DISCARD);
1909*0Sstevel@tonic-gate }
1910*0Sstevel@tonic-gate }
1911*0Sstevel@tonic-gate }
1912*0Sstevel@tonic-gate }
1913*0Sstevel@tonic-gate
1914*0Sstevel@tonic-gate OP *
Perl_localize(pTHX_ OP * o,I32 lex)1915*0Sstevel@tonic-gate Perl_localize(pTHX_ OP *o, I32 lex)
1916*0Sstevel@tonic-gate {
1917*0Sstevel@tonic-gate if (o->op_flags & OPf_PARENS)
1918*0Sstevel@tonic-gate /* [perl #17376]: this appears to be premature, and results in code such as
1919*0Sstevel@tonic-gate C< our(%x); > executing in list mode rather than void mode */
1920*0Sstevel@tonic-gate #if 0
1921*0Sstevel@tonic-gate list(o);
1922*0Sstevel@tonic-gate #else
1923*0Sstevel@tonic-gate ;
1924*0Sstevel@tonic-gate #endif
1925*0Sstevel@tonic-gate else {
1926*0Sstevel@tonic-gate if (ckWARN(WARN_PARENTHESIS)
1927*0Sstevel@tonic-gate && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
1928*0Sstevel@tonic-gate {
1929*0Sstevel@tonic-gate char *s = PL_bufptr;
1930*0Sstevel@tonic-gate bool sigil = FALSE;
1931*0Sstevel@tonic-gate
1932*0Sstevel@tonic-gate /* some heuristics to detect a potential error */
1933*0Sstevel@tonic-gate while (*s && (strchr(", \t\n", *s)))
1934*0Sstevel@tonic-gate s++;
1935*0Sstevel@tonic-gate
1936*0Sstevel@tonic-gate while (1) {
1937*0Sstevel@tonic-gate if (*s && strchr("@$%*", *s) && *++s
1938*0Sstevel@tonic-gate && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1939*0Sstevel@tonic-gate s++;
1940*0Sstevel@tonic-gate sigil = TRUE;
1941*0Sstevel@tonic-gate while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1942*0Sstevel@tonic-gate s++;
1943*0Sstevel@tonic-gate while (*s && (strchr(", \t\n", *s)))
1944*0Sstevel@tonic-gate s++;
1945*0Sstevel@tonic-gate }
1946*0Sstevel@tonic-gate else
1947*0Sstevel@tonic-gate break;
1948*0Sstevel@tonic-gate }
1949*0Sstevel@tonic-gate if (sigil && (*s == ';' || *s == '=')) {
1950*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
1951*0Sstevel@tonic-gate "Parentheses missing around \"%s\" list",
1952*0Sstevel@tonic-gate lex ? (PL_in_my == KEY_our ? "our" : "my")
1953*0Sstevel@tonic-gate : "local");
1954*0Sstevel@tonic-gate }
1955*0Sstevel@tonic-gate }
1956*0Sstevel@tonic-gate }
1957*0Sstevel@tonic-gate if (lex)
1958*0Sstevel@tonic-gate o = my(o);
1959*0Sstevel@tonic-gate else
1960*0Sstevel@tonic-gate o = mod(o, OP_NULL); /* a bit kludgey */
1961*0Sstevel@tonic-gate PL_in_my = FALSE;
1962*0Sstevel@tonic-gate PL_in_my_stash = Nullhv;
1963*0Sstevel@tonic-gate return o;
1964*0Sstevel@tonic-gate }
1965*0Sstevel@tonic-gate
1966*0Sstevel@tonic-gate OP *
Perl_jmaybe(pTHX_ OP * o)1967*0Sstevel@tonic-gate Perl_jmaybe(pTHX_ OP *o)
1968*0Sstevel@tonic-gate {
1969*0Sstevel@tonic-gate if (o->op_type == OP_LIST) {
1970*0Sstevel@tonic-gate OP *o2;
1971*0Sstevel@tonic-gate #ifdef USE_5005THREADS
1972*0Sstevel@tonic-gate o2 = newOP(OP_THREADSV, 0);
1973*0Sstevel@tonic-gate o2->op_targ = find_threadsv(";");
1974*0Sstevel@tonic-gate #else
1975*0Sstevel@tonic-gate o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1976*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
1977*0Sstevel@tonic-gate o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1978*0Sstevel@tonic-gate }
1979*0Sstevel@tonic-gate return o;
1980*0Sstevel@tonic-gate }
1981*0Sstevel@tonic-gate
1982*0Sstevel@tonic-gate OP *
Perl_fold_constants(pTHX_ register OP * o)1983*0Sstevel@tonic-gate Perl_fold_constants(pTHX_ register OP *o)
1984*0Sstevel@tonic-gate {
1985*0Sstevel@tonic-gate register OP *curop;
1986*0Sstevel@tonic-gate I32 type = o->op_type;
1987*0Sstevel@tonic-gate SV *sv;
1988*0Sstevel@tonic-gate
1989*0Sstevel@tonic-gate if (PL_opargs[type] & OA_RETSCALAR)
1990*0Sstevel@tonic-gate scalar(o);
1991*0Sstevel@tonic-gate if (PL_opargs[type] & OA_TARGET && !o->op_targ)
1992*0Sstevel@tonic-gate o->op_targ = pad_alloc(type, SVs_PADTMP);
1993*0Sstevel@tonic-gate
1994*0Sstevel@tonic-gate /* integerize op, unless it happens to be C<-foo>.
1995*0Sstevel@tonic-gate * XXX should pp_i_negate() do magic string negation instead? */
1996*0Sstevel@tonic-gate if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
1997*0Sstevel@tonic-gate && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
1998*0Sstevel@tonic-gate && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
1999*0Sstevel@tonic-gate {
2000*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2001*0Sstevel@tonic-gate }
2002*0Sstevel@tonic-gate
2003*0Sstevel@tonic-gate if (!(PL_opargs[type] & OA_FOLDCONST))
2004*0Sstevel@tonic-gate goto nope;
2005*0Sstevel@tonic-gate
2006*0Sstevel@tonic-gate switch (type) {
2007*0Sstevel@tonic-gate case OP_NEGATE:
2008*0Sstevel@tonic-gate /* XXX might want a ck_negate() for this */
2009*0Sstevel@tonic-gate cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2010*0Sstevel@tonic-gate break;
2011*0Sstevel@tonic-gate case OP_UCFIRST:
2012*0Sstevel@tonic-gate case OP_LCFIRST:
2013*0Sstevel@tonic-gate case OP_UC:
2014*0Sstevel@tonic-gate case OP_LC:
2015*0Sstevel@tonic-gate case OP_SLT:
2016*0Sstevel@tonic-gate case OP_SGT:
2017*0Sstevel@tonic-gate case OP_SLE:
2018*0Sstevel@tonic-gate case OP_SGE:
2019*0Sstevel@tonic-gate case OP_SCMP:
2020*0Sstevel@tonic-gate /* XXX what about the numeric ops? */
2021*0Sstevel@tonic-gate if (PL_hints & HINT_LOCALE)
2022*0Sstevel@tonic-gate goto nope;
2023*0Sstevel@tonic-gate }
2024*0Sstevel@tonic-gate
2025*0Sstevel@tonic-gate if (PL_error_count)
2026*0Sstevel@tonic-gate goto nope; /* Don't try to run w/ errors */
2027*0Sstevel@tonic-gate
2028*0Sstevel@tonic-gate for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2029*0Sstevel@tonic-gate if ((curop->op_type != OP_CONST ||
2030*0Sstevel@tonic-gate (curop->op_private & OPpCONST_BARE)) &&
2031*0Sstevel@tonic-gate curop->op_type != OP_LIST &&
2032*0Sstevel@tonic-gate curop->op_type != OP_SCALAR &&
2033*0Sstevel@tonic-gate curop->op_type != OP_NULL &&
2034*0Sstevel@tonic-gate curop->op_type != OP_PUSHMARK)
2035*0Sstevel@tonic-gate {
2036*0Sstevel@tonic-gate goto nope;
2037*0Sstevel@tonic-gate }
2038*0Sstevel@tonic-gate }
2039*0Sstevel@tonic-gate
2040*0Sstevel@tonic-gate curop = LINKLIST(o);
2041*0Sstevel@tonic-gate o->op_next = 0;
2042*0Sstevel@tonic-gate PL_op = curop;
2043*0Sstevel@tonic-gate CALLRUNOPS(aTHX);
2044*0Sstevel@tonic-gate sv = *(PL_stack_sp--);
2045*0Sstevel@tonic-gate if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2046*0Sstevel@tonic-gate pad_swipe(o->op_targ, FALSE);
2047*0Sstevel@tonic-gate else if (SvTEMP(sv)) { /* grab mortal temp? */
2048*0Sstevel@tonic-gate (void)SvREFCNT_inc(sv);
2049*0Sstevel@tonic-gate SvTEMP_off(sv);
2050*0Sstevel@tonic-gate }
2051*0Sstevel@tonic-gate op_free(o);
2052*0Sstevel@tonic-gate if (type == OP_RV2GV)
2053*0Sstevel@tonic-gate return newGVOP(OP_GV, 0, (GV*)sv);
2054*0Sstevel@tonic-gate return newSVOP(OP_CONST, 0, sv);
2055*0Sstevel@tonic-gate
2056*0Sstevel@tonic-gate nope:
2057*0Sstevel@tonic-gate return o;
2058*0Sstevel@tonic-gate }
2059*0Sstevel@tonic-gate
2060*0Sstevel@tonic-gate OP *
Perl_gen_constant_list(pTHX_ register OP * o)2061*0Sstevel@tonic-gate Perl_gen_constant_list(pTHX_ register OP *o)
2062*0Sstevel@tonic-gate {
2063*0Sstevel@tonic-gate register OP *curop;
2064*0Sstevel@tonic-gate I32 oldtmps_floor = PL_tmps_floor;
2065*0Sstevel@tonic-gate
2066*0Sstevel@tonic-gate list(o);
2067*0Sstevel@tonic-gate if (PL_error_count)
2068*0Sstevel@tonic-gate return o; /* Don't attempt to run with errors */
2069*0Sstevel@tonic-gate
2070*0Sstevel@tonic-gate PL_op = curop = LINKLIST(o);
2071*0Sstevel@tonic-gate o->op_next = 0;
2072*0Sstevel@tonic-gate CALL_PEEP(curop);
2073*0Sstevel@tonic-gate pp_pushmark();
2074*0Sstevel@tonic-gate CALLRUNOPS(aTHX);
2075*0Sstevel@tonic-gate PL_op = curop;
2076*0Sstevel@tonic-gate pp_anonlist();
2077*0Sstevel@tonic-gate PL_tmps_floor = oldtmps_floor;
2078*0Sstevel@tonic-gate
2079*0Sstevel@tonic-gate o->op_type = OP_RV2AV;
2080*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2081*0Sstevel@tonic-gate o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2082*0Sstevel@tonic-gate o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2083*0Sstevel@tonic-gate o->op_seq = 0; /* needs to be revisited in peep() */
2084*0Sstevel@tonic-gate curop = ((UNOP*)o)->op_first;
2085*0Sstevel@tonic-gate ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2086*0Sstevel@tonic-gate op_free(curop);
2087*0Sstevel@tonic-gate linklist(o);
2088*0Sstevel@tonic-gate return list(o);
2089*0Sstevel@tonic-gate }
2090*0Sstevel@tonic-gate
2091*0Sstevel@tonic-gate OP *
Perl_convert(pTHX_ I32 type,I32 flags,OP * o)2092*0Sstevel@tonic-gate Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2093*0Sstevel@tonic-gate {
2094*0Sstevel@tonic-gate if (!o || o->op_type != OP_LIST)
2095*0Sstevel@tonic-gate o = newLISTOP(OP_LIST, 0, o, Nullop);
2096*0Sstevel@tonic-gate else
2097*0Sstevel@tonic-gate o->op_flags &= ~OPf_WANT;
2098*0Sstevel@tonic-gate
2099*0Sstevel@tonic-gate if (!(PL_opargs[type] & OA_MARK))
2100*0Sstevel@tonic-gate op_null(cLISTOPo->op_first);
2101*0Sstevel@tonic-gate
2102*0Sstevel@tonic-gate o->op_type = (OPCODE)type;
2103*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[type];
2104*0Sstevel@tonic-gate o->op_flags |= flags;
2105*0Sstevel@tonic-gate
2106*0Sstevel@tonic-gate o = CHECKOP(type, o);
2107*0Sstevel@tonic-gate if (o->op_type != type)
2108*0Sstevel@tonic-gate return o;
2109*0Sstevel@tonic-gate
2110*0Sstevel@tonic-gate return fold_constants(o);
2111*0Sstevel@tonic-gate }
2112*0Sstevel@tonic-gate
2113*0Sstevel@tonic-gate /* List constructors */
2114*0Sstevel@tonic-gate
2115*0Sstevel@tonic-gate OP *
Perl_append_elem(pTHX_ I32 type,OP * first,OP * last)2116*0Sstevel@tonic-gate Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2117*0Sstevel@tonic-gate {
2118*0Sstevel@tonic-gate if (!first)
2119*0Sstevel@tonic-gate return last;
2120*0Sstevel@tonic-gate
2121*0Sstevel@tonic-gate if (!last)
2122*0Sstevel@tonic-gate return first;
2123*0Sstevel@tonic-gate
2124*0Sstevel@tonic-gate if (first->op_type != type
2125*0Sstevel@tonic-gate || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2126*0Sstevel@tonic-gate {
2127*0Sstevel@tonic-gate return newLISTOP(type, 0, first, last);
2128*0Sstevel@tonic-gate }
2129*0Sstevel@tonic-gate
2130*0Sstevel@tonic-gate if (first->op_flags & OPf_KIDS)
2131*0Sstevel@tonic-gate ((LISTOP*)first)->op_last->op_sibling = last;
2132*0Sstevel@tonic-gate else {
2133*0Sstevel@tonic-gate first->op_flags |= OPf_KIDS;
2134*0Sstevel@tonic-gate ((LISTOP*)first)->op_first = last;
2135*0Sstevel@tonic-gate }
2136*0Sstevel@tonic-gate ((LISTOP*)first)->op_last = last;
2137*0Sstevel@tonic-gate return first;
2138*0Sstevel@tonic-gate }
2139*0Sstevel@tonic-gate
2140*0Sstevel@tonic-gate OP *
Perl_append_list(pTHX_ I32 type,LISTOP * first,LISTOP * last)2141*0Sstevel@tonic-gate Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2142*0Sstevel@tonic-gate {
2143*0Sstevel@tonic-gate if (!first)
2144*0Sstevel@tonic-gate return (OP*)last;
2145*0Sstevel@tonic-gate
2146*0Sstevel@tonic-gate if (!last)
2147*0Sstevel@tonic-gate return (OP*)first;
2148*0Sstevel@tonic-gate
2149*0Sstevel@tonic-gate if (first->op_type != type)
2150*0Sstevel@tonic-gate return prepend_elem(type, (OP*)first, (OP*)last);
2151*0Sstevel@tonic-gate
2152*0Sstevel@tonic-gate if (last->op_type != type)
2153*0Sstevel@tonic-gate return append_elem(type, (OP*)first, (OP*)last);
2154*0Sstevel@tonic-gate
2155*0Sstevel@tonic-gate first->op_last->op_sibling = last->op_first;
2156*0Sstevel@tonic-gate first->op_last = last->op_last;
2157*0Sstevel@tonic-gate first->op_flags |= (last->op_flags & OPf_KIDS);
2158*0Sstevel@tonic-gate
2159*0Sstevel@tonic-gate FreeOp(last);
2160*0Sstevel@tonic-gate
2161*0Sstevel@tonic-gate return (OP*)first;
2162*0Sstevel@tonic-gate }
2163*0Sstevel@tonic-gate
2164*0Sstevel@tonic-gate OP *
Perl_prepend_elem(pTHX_ I32 type,OP * first,OP * last)2165*0Sstevel@tonic-gate Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2166*0Sstevel@tonic-gate {
2167*0Sstevel@tonic-gate if (!first)
2168*0Sstevel@tonic-gate return last;
2169*0Sstevel@tonic-gate
2170*0Sstevel@tonic-gate if (!last)
2171*0Sstevel@tonic-gate return first;
2172*0Sstevel@tonic-gate
2173*0Sstevel@tonic-gate if (last->op_type == type) {
2174*0Sstevel@tonic-gate if (type == OP_LIST) { /* already a PUSHMARK there */
2175*0Sstevel@tonic-gate first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2176*0Sstevel@tonic-gate ((LISTOP*)last)->op_first->op_sibling = first;
2177*0Sstevel@tonic-gate if (!(first->op_flags & OPf_PARENS))
2178*0Sstevel@tonic-gate last->op_flags &= ~OPf_PARENS;
2179*0Sstevel@tonic-gate }
2180*0Sstevel@tonic-gate else {
2181*0Sstevel@tonic-gate if (!(last->op_flags & OPf_KIDS)) {
2182*0Sstevel@tonic-gate ((LISTOP*)last)->op_last = first;
2183*0Sstevel@tonic-gate last->op_flags |= OPf_KIDS;
2184*0Sstevel@tonic-gate }
2185*0Sstevel@tonic-gate first->op_sibling = ((LISTOP*)last)->op_first;
2186*0Sstevel@tonic-gate ((LISTOP*)last)->op_first = first;
2187*0Sstevel@tonic-gate }
2188*0Sstevel@tonic-gate last->op_flags |= OPf_KIDS;
2189*0Sstevel@tonic-gate return last;
2190*0Sstevel@tonic-gate }
2191*0Sstevel@tonic-gate
2192*0Sstevel@tonic-gate return newLISTOP(type, 0, first, last);
2193*0Sstevel@tonic-gate }
2194*0Sstevel@tonic-gate
2195*0Sstevel@tonic-gate /* Constructors */
2196*0Sstevel@tonic-gate
2197*0Sstevel@tonic-gate OP *
Perl_newNULLLIST(pTHX)2198*0Sstevel@tonic-gate Perl_newNULLLIST(pTHX)
2199*0Sstevel@tonic-gate {
2200*0Sstevel@tonic-gate return newOP(OP_STUB, 0);
2201*0Sstevel@tonic-gate }
2202*0Sstevel@tonic-gate
2203*0Sstevel@tonic-gate OP *
Perl_force_list(pTHX_ OP * o)2204*0Sstevel@tonic-gate Perl_force_list(pTHX_ OP *o)
2205*0Sstevel@tonic-gate {
2206*0Sstevel@tonic-gate if (!o || o->op_type != OP_LIST)
2207*0Sstevel@tonic-gate o = newLISTOP(OP_LIST, 0, o, Nullop);
2208*0Sstevel@tonic-gate op_null(o);
2209*0Sstevel@tonic-gate return o;
2210*0Sstevel@tonic-gate }
2211*0Sstevel@tonic-gate
2212*0Sstevel@tonic-gate OP *
Perl_newLISTOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)2213*0Sstevel@tonic-gate Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2214*0Sstevel@tonic-gate {
2215*0Sstevel@tonic-gate LISTOP *listop;
2216*0Sstevel@tonic-gate
2217*0Sstevel@tonic-gate NewOp(1101, listop, 1, LISTOP);
2218*0Sstevel@tonic-gate
2219*0Sstevel@tonic-gate listop->op_type = (OPCODE)type;
2220*0Sstevel@tonic-gate listop->op_ppaddr = PL_ppaddr[type];
2221*0Sstevel@tonic-gate if (first || last)
2222*0Sstevel@tonic-gate flags |= OPf_KIDS;
2223*0Sstevel@tonic-gate listop->op_flags = (U8)flags;
2224*0Sstevel@tonic-gate
2225*0Sstevel@tonic-gate if (!last && first)
2226*0Sstevel@tonic-gate last = first;
2227*0Sstevel@tonic-gate else if (!first && last)
2228*0Sstevel@tonic-gate first = last;
2229*0Sstevel@tonic-gate else if (first)
2230*0Sstevel@tonic-gate first->op_sibling = last;
2231*0Sstevel@tonic-gate listop->op_first = first;
2232*0Sstevel@tonic-gate listop->op_last = last;
2233*0Sstevel@tonic-gate if (type == OP_LIST) {
2234*0Sstevel@tonic-gate OP* pushop;
2235*0Sstevel@tonic-gate pushop = newOP(OP_PUSHMARK, 0);
2236*0Sstevel@tonic-gate pushop->op_sibling = first;
2237*0Sstevel@tonic-gate listop->op_first = pushop;
2238*0Sstevel@tonic-gate listop->op_flags |= OPf_KIDS;
2239*0Sstevel@tonic-gate if (!last)
2240*0Sstevel@tonic-gate listop->op_last = pushop;
2241*0Sstevel@tonic-gate }
2242*0Sstevel@tonic-gate
2243*0Sstevel@tonic-gate return CHECKOP(type, listop);
2244*0Sstevel@tonic-gate }
2245*0Sstevel@tonic-gate
2246*0Sstevel@tonic-gate OP *
Perl_newOP(pTHX_ I32 type,I32 flags)2247*0Sstevel@tonic-gate Perl_newOP(pTHX_ I32 type, I32 flags)
2248*0Sstevel@tonic-gate {
2249*0Sstevel@tonic-gate OP *o;
2250*0Sstevel@tonic-gate NewOp(1101, o, 1, OP);
2251*0Sstevel@tonic-gate o->op_type = (OPCODE)type;
2252*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[type];
2253*0Sstevel@tonic-gate o->op_flags = (U8)flags;
2254*0Sstevel@tonic-gate
2255*0Sstevel@tonic-gate o->op_next = o;
2256*0Sstevel@tonic-gate o->op_private = (U8)(0 | (flags >> 8));
2257*0Sstevel@tonic-gate if (PL_opargs[type] & OA_RETSCALAR)
2258*0Sstevel@tonic-gate scalar(o);
2259*0Sstevel@tonic-gate if (PL_opargs[type] & OA_TARGET)
2260*0Sstevel@tonic-gate o->op_targ = pad_alloc(type, SVs_PADTMP);
2261*0Sstevel@tonic-gate return CHECKOP(type, o);
2262*0Sstevel@tonic-gate }
2263*0Sstevel@tonic-gate
2264*0Sstevel@tonic-gate OP *
Perl_newUNOP(pTHX_ I32 type,I32 flags,OP * first)2265*0Sstevel@tonic-gate Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2266*0Sstevel@tonic-gate {
2267*0Sstevel@tonic-gate UNOP *unop;
2268*0Sstevel@tonic-gate
2269*0Sstevel@tonic-gate if (!first)
2270*0Sstevel@tonic-gate first = newOP(OP_STUB, 0);
2271*0Sstevel@tonic-gate if (PL_opargs[type] & OA_MARK)
2272*0Sstevel@tonic-gate first = force_list(first);
2273*0Sstevel@tonic-gate
2274*0Sstevel@tonic-gate NewOp(1101, unop, 1, UNOP);
2275*0Sstevel@tonic-gate unop->op_type = (OPCODE)type;
2276*0Sstevel@tonic-gate unop->op_ppaddr = PL_ppaddr[type];
2277*0Sstevel@tonic-gate unop->op_first = first;
2278*0Sstevel@tonic-gate unop->op_flags = flags | OPf_KIDS;
2279*0Sstevel@tonic-gate unop->op_private = (U8)(1 | (flags >> 8));
2280*0Sstevel@tonic-gate unop = (UNOP*) CHECKOP(type, unop);
2281*0Sstevel@tonic-gate if (unop->op_next)
2282*0Sstevel@tonic-gate return (OP*)unop;
2283*0Sstevel@tonic-gate
2284*0Sstevel@tonic-gate return fold_constants((OP *) unop);
2285*0Sstevel@tonic-gate }
2286*0Sstevel@tonic-gate
2287*0Sstevel@tonic-gate OP *
Perl_newBINOP(pTHX_ I32 type,I32 flags,OP * first,OP * last)2288*0Sstevel@tonic-gate Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2289*0Sstevel@tonic-gate {
2290*0Sstevel@tonic-gate BINOP *binop;
2291*0Sstevel@tonic-gate NewOp(1101, binop, 1, BINOP);
2292*0Sstevel@tonic-gate
2293*0Sstevel@tonic-gate if (!first)
2294*0Sstevel@tonic-gate first = newOP(OP_NULL, 0);
2295*0Sstevel@tonic-gate
2296*0Sstevel@tonic-gate binop->op_type = (OPCODE)type;
2297*0Sstevel@tonic-gate binop->op_ppaddr = PL_ppaddr[type];
2298*0Sstevel@tonic-gate binop->op_first = first;
2299*0Sstevel@tonic-gate binop->op_flags = flags | OPf_KIDS;
2300*0Sstevel@tonic-gate if (!last) {
2301*0Sstevel@tonic-gate last = first;
2302*0Sstevel@tonic-gate binop->op_private = (U8)(1 | (flags >> 8));
2303*0Sstevel@tonic-gate }
2304*0Sstevel@tonic-gate else {
2305*0Sstevel@tonic-gate binop->op_private = (U8)(2 | (flags >> 8));
2306*0Sstevel@tonic-gate first->op_sibling = last;
2307*0Sstevel@tonic-gate }
2308*0Sstevel@tonic-gate
2309*0Sstevel@tonic-gate binop = (BINOP*)CHECKOP(type, binop);
2310*0Sstevel@tonic-gate if (binop->op_next || binop->op_type != (OPCODE)type)
2311*0Sstevel@tonic-gate return (OP*)binop;
2312*0Sstevel@tonic-gate
2313*0Sstevel@tonic-gate binop->op_last = binop->op_first->op_sibling;
2314*0Sstevel@tonic-gate
2315*0Sstevel@tonic-gate return fold_constants((OP *)binop);
2316*0Sstevel@tonic-gate }
2317*0Sstevel@tonic-gate
2318*0Sstevel@tonic-gate static int
uvcompare(const void * a,const void * b)2319*0Sstevel@tonic-gate uvcompare(const void *a, const void *b)
2320*0Sstevel@tonic-gate {
2321*0Sstevel@tonic-gate if (*((UV *)a) < (*(UV *)b))
2322*0Sstevel@tonic-gate return -1;
2323*0Sstevel@tonic-gate if (*((UV *)a) > (*(UV *)b))
2324*0Sstevel@tonic-gate return 1;
2325*0Sstevel@tonic-gate if (*((UV *)a+1) < (*(UV *)b+1))
2326*0Sstevel@tonic-gate return -1;
2327*0Sstevel@tonic-gate if (*((UV *)a+1) > (*(UV *)b+1))
2328*0Sstevel@tonic-gate return 1;
2329*0Sstevel@tonic-gate return 0;
2330*0Sstevel@tonic-gate }
2331*0Sstevel@tonic-gate
2332*0Sstevel@tonic-gate OP *
Perl_pmtrans(pTHX_ OP * o,OP * expr,OP * repl)2333*0Sstevel@tonic-gate Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2334*0Sstevel@tonic-gate {
2335*0Sstevel@tonic-gate SV *tstr = ((SVOP*)expr)->op_sv;
2336*0Sstevel@tonic-gate SV *rstr = ((SVOP*)repl)->op_sv;
2337*0Sstevel@tonic-gate STRLEN tlen;
2338*0Sstevel@tonic-gate STRLEN rlen;
2339*0Sstevel@tonic-gate U8 *t = (U8*)SvPV(tstr, tlen);
2340*0Sstevel@tonic-gate U8 *r = (U8*)SvPV(rstr, rlen);
2341*0Sstevel@tonic-gate register I32 i;
2342*0Sstevel@tonic-gate register I32 j;
2343*0Sstevel@tonic-gate I32 del;
2344*0Sstevel@tonic-gate I32 complement;
2345*0Sstevel@tonic-gate I32 squash;
2346*0Sstevel@tonic-gate I32 grows = 0;
2347*0Sstevel@tonic-gate register short *tbl;
2348*0Sstevel@tonic-gate
2349*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE;
2350*0Sstevel@tonic-gate complement = o->op_private & OPpTRANS_COMPLEMENT;
2351*0Sstevel@tonic-gate del = o->op_private & OPpTRANS_DELETE;
2352*0Sstevel@tonic-gate squash = o->op_private & OPpTRANS_SQUASH;
2353*0Sstevel@tonic-gate
2354*0Sstevel@tonic-gate if (SvUTF8(tstr))
2355*0Sstevel@tonic-gate o->op_private |= OPpTRANS_FROM_UTF;
2356*0Sstevel@tonic-gate
2357*0Sstevel@tonic-gate if (SvUTF8(rstr))
2358*0Sstevel@tonic-gate o->op_private |= OPpTRANS_TO_UTF;
2359*0Sstevel@tonic-gate
2360*0Sstevel@tonic-gate if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2361*0Sstevel@tonic-gate SV* listsv = newSVpvn("# comment\n",10);
2362*0Sstevel@tonic-gate SV* transv = 0;
2363*0Sstevel@tonic-gate U8* tend = t + tlen;
2364*0Sstevel@tonic-gate U8* rend = r + rlen;
2365*0Sstevel@tonic-gate STRLEN ulen;
2366*0Sstevel@tonic-gate UV tfirst = 1;
2367*0Sstevel@tonic-gate UV tlast = 0;
2368*0Sstevel@tonic-gate IV tdiff;
2369*0Sstevel@tonic-gate UV rfirst = 1;
2370*0Sstevel@tonic-gate UV rlast = 0;
2371*0Sstevel@tonic-gate IV rdiff;
2372*0Sstevel@tonic-gate IV diff;
2373*0Sstevel@tonic-gate I32 none = 0;
2374*0Sstevel@tonic-gate U32 max = 0;
2375*0Sstevel@tonic-gate I32 bits;
2376*0Sstevel@tonic-gate I32 havefinal = 0;
2377*0Sstevel@tonic-gate U32 final = 0;
2378*0Sstevel@tonic-gate I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2379*0Sstevel@tonic-gate I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2380*0Sstevel@tonic-gate U8* tsave = NULL;
2381*0Sstevel@tonic-gate U8* rsave = NULL;
2382*0Sstevel@tonic-gate
2383*0Sstevel@tonic-gate if (!from_utf) {
2384*0Sstevel@tonic-gate STRLEN len = tlen;
2385*0Sstevel@tonic-gate tsave = t = bytes_to_utf8(t, &len);
2386*0Sstevel@tonic-gate tend = t + len;
2387*0Sstevel@tonic-gate }
2388*0Sstevel@tonic-gate if (!to_utf && rlen) {
2389*0Sstevel@tonic-gate STRLEN len = rlen;
2390*0Sstevel@tonic-gate rsave = r = bytes_to_utf8(r, &len);
2391*0Sstevel@tonic-gate rend = r + len;
2392*0Sstevel@tonic-gate }
2393*0Sstevel@tonic-gate
2394*0Sstevel@tonic-gate /* There are several snags with this code on EBCDIC:
2395*0Sstevel@tonic-gate 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2396*0Sstevel@tonic-gate 2. scan_const() in toke.c has encoded chars in native encoding which makes
2397*0Sstevel@tonic-gate ranges at least in EBCDIC 0..255 range the bottom odd.
2398*0Sstevel@tonic-gate */
2399*0Sstevel@tonic-gate
2400*0Sstevel@tonic-gate if (complement) {
2401*0Sstevel@tonic-gate U8 tmpbuf[UTF8_MAXLEN+1];
2402*0Sstevel@tonic-gate UV *cp;
2403*0Sstevel@tonic-gate UV nextmin = 0;
2404*0Sstevel@tonic-gate New(1109, cp, 2*tlen, UV);
2405*0Sstevel@tonic-gate i = 0;
2406*0Sstevel@tonic-gate transv = newSVpvn("",0);
2407*0Sstevel@tonic-gate while (t < tend) {
2408*0Sstevel@tonic-gate cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2409*0Sstevel@tonic-gate t += ulen;
2410*0Sstevel@tonic-gate if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2411*0Sstevel@tonic-gate t++;
2412*0Sstevel@tonic-gate cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2413*0Sstevel@tonic-gate t += ulen;
2414*0Sstevel@tonic-gate }
2415*0Sstevel@tonic-gate else {
2416*0Sstevel@tonic-gate cp[2*i+1] = cp[2*i];
2417*0Sstevel@tonic-gate }
2418*0Sstevel@tonic-gate i++;
2419*0Sstevel@tonic-gate }
2420*0Sstevel@tonic-gate qsort(cp, i, 2*sizeof(UV), uvcompare);
2421*0Sstevel@tonic-gate for (j = 0; j < i; j++) {
2422*0Sstevel@tonic-gate UV val = cp[2*j];
2423*0Sstevel@tonic-gate diff = val - nextmin;
2424*0Sstevel@tonic-gate if (diff > 0) {
2425*0Sstevel@tonic-gate t = uvuni_to_utf8(tmpbuf,nextmin);
2426*0Sstevel@tonic-gate sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2427*0Sstevel@tonic-gate if (diff > 1) {
2428*0Sstevel@tonic-gate U8 range_mark = UTF_TO_NATIVE(0xff);
2429*0Sstevel@tonic-gate t = uvuni_to_utf8(tmpbuf, val - 1);
2430*0Sstevel@tonic-gate sv_catpvn(transv, (char *)&range_mark, 1);
2431*0Sstevel@tonic-gate sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2432*0Sstevel@tonic-gate }
2433*0Sstevel@tonic-gate }
2434*0Sstevel@tonic-gate val = cp[2*j+1];
2435*0Sstevel@tonic-gate if (val >= nextmin)
2436*0Sstevel@tonic-gate nextmin = val + 1;
2437*0Sstevel@tonic-gate }
2438*0Sstevel@tonic-gate t = uvuni_to_utf8(tmpbuf,nextmin);
2439*0Sstevel@tonic-gate sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2440*0Sstevel@tonic-gate {
2441*0Sstevel@tonic-gate U8 range_mark = UTF_TO_NATIVE(0xff);
2442*0Sstevel@tonic-gate sv_catpvn(transv, (char *)&range_mark, 1);
2443*0Sstevel@tonic-gate }
2444*0Sstevel@tonic-gate t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2445*0Sstevel@tonic-gate UNICODE_ALLOW_SUPER);
2446*0Sstevel@tonic-gate sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2447*0Sstevel@tonic-gate t = (U8*)SvPVX(transv);
2448*0Sstevel@tonic-gate tlen = SvCUR(transv);
2449*0Sstevel@tonic-gate tend = t + tlen;
2450*0Sstevel@tonic-gate Safefree(cp);
2451*0Sstevel@tonic-gate }
2452*0Sstevel@tonic-gate else if (!rlen && !del) {
2453*0Sstevel@tonic-gate r = t; rlen = tlen; rend = tend;
2454*0Sstevel@tonic-gate }
2455*0Sstevel@tonic-gate if (!squash) {
2456*0Sstevel@tonic-gate if ((!rlen && !del) || t == r ||
2457*0Sstevel@tonic-gate (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2458*0Sstevel@tonic-gate {
2459*0Sstevel@tonic-gate o->op_private |= OPpTRANS_IDENTICAL;
2460*0Sstevel@tonic-gate }
2461*0Sstevel@tonic-gate }
2462*0Sstevel@tonic-gate
2463*0Sstevel@tonic-gate while (t < tend || tfirst <= tlast) {
2464*0Sstevel@tonic-gate /* see if we need more "t" chars */
2465*0Sstevel@tonic-gate if (tfirst > tlast) {
2466*0Sstevel@tonic-gate tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2467*0Sstevel@tonic-gate t += ulen;
2468*0Sstevel@tonic-gate if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2469*0Sstevel@tonic-gate t++;
2470*0Sstevel@tonic-gate tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2471*0Sstevel@tonic-gate t += ulen;
2472*0Sstevel@tonic-gate }
2473*0Sstevel@tonic-gate else
2474*0Sstevel@tonic-gate tlast = tfirst;
2475*0Sstevel@tonic-gate }
2476*0Sstevel@tonic-gate
2477*0Sstevel@tonic-gate /* now see if we need more "r" chars */
2478*0Sstevel@tonic-gate if (rfirst > rlast) {
2479*0Sstevel@tonic-gate if (r < rend) {
2480*0Sstevel@tonic-gate rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2481*0Sstevel@tonic-gate r += ulen;
2482*0Sstevel@tonic-gate if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2483*0Sstevel@tonic-gate r++;
2484*0Sstevel@tonic-gate rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2485*0Sstevel@tonic-gate r += ulen;
2486*0Sstevel@tonic-gate }
2487*0Sstevel@tonic-gate else
2488*0Sstevel@tonic-gate rlast = rfirst;
2489*0Sstevel@tonic-gate }
2490*0Sstevel@tonic-gate else {
2491*0Sstevel@tonic-gate if (!havefinal++)
2492*0Sstevel@tonic-gate final = rlast;
2493*0Sstevel@tonic-gate rfirst = rlast = 0xffffffff;
2494*0Sstevel@tonic-gate }
2495*0Sstevel@tonic-gate }
2496*0Sstevel@tonic-gate
2497*0Sstevel@tonic-gate /* now see which range will peter our first, if either. */
2498*0Sstevel@tonic-gate tdiff = tlast - tfirst;
2499*0Sstevel@tonic-gate rdiff = rlast - rfirst;
2500*0Sstevel@tonic-gate
2501*0Sstevel@tonic-gate if (tdiff <= rdiff)
2502*0Sstevel@tonic-gate diff = tdiff;
2503*0Sstevel@tonic-gate else
2504*0Sstevel@tonic-gate diff = rdiff;
2505*0Sstevel@tonic-gate
2506*0Sstevel@tonic-gate if (rfirst == 0xffffffff) {
2507*0Sstevel@tonic-gate diff = tdiff; /* oops, pretend rdiff is infinite */
2508*0Sstevel@tonic-gate if (diff > 0)
2509*0Sstevel@tonic-gate Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2510*0Sstevel@tonic-gate (long)tfirst, (long)tlast);
2511*0Sstevel@tonic-gate else
2512*0Sstevel@tonic-gate Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2513*0Sstevel@tonic-gate }
2514*0Sstevel@tonic-gate else {
2515*0Sstevel@tonic-gate if (diff > 0)
2516*0Sstevel@tonic-gate Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2517*0Sstevel@tonic-gate (long)tfirst, (long)(tfirst + diff),
2518*0Sstevel@tonic-gate (long)rfirst);
2519*0Sstevel@tonic-gate else
2520*0Sstevel@tonic-gate Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2521*0Sstevel@tonic-gate (long)tfirst, (long)rfirst);
2522*0Sstevel@tonic-gate
2523*0Sstevel@tonic-gate if (rfirst + diff > max)
2524*0Sstevel@tonic-gate max = rfirst + diff;
2525*0Sstevel@tonic-gate if (!grows)
2526*0Sstevel@tonic-gate grows = (tfirst < rfirst &&
2527*0Sstevel@tonic-gate UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2528*0Sstevel@tonic-gate rfirst += diff + 1;
2529*0Sstevel@tonic-gate }
2530*0Sstevel@tonic-gate tfirst += diff + 1;
2531*0Sstevel@tonic-gate }
2532*0Sstevel@tonic-gate
2533*0Sstevel@tonic-gate none = ++max;
2534*0Sstevel@tonic-gate if (del)
2535*0Sstevel@tonic-gate del = ++max;
2536*0Sstevel@tonic-gate
2537*0Sstevel@tonic-gate if (max > 0xffff)
2538*0Sstevel@tonic-gate bits = 32;
2539*0Sstevel@tonic-gate else if (max > 0xff)
2540*0Sstevel@tonic-gate bits = 16;
2541*0Sstevel@tonic-gate else
2542*0Sstevel@tonic-gate bits = 8;
2543*0Sstevel@tonic-gate
2544*0Sstevel@tonic-gate Safefree(cPVOPo->op_pv);
2545*0Sstevel@tonic-gate cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2546*0Sstevel@tonic-gate SvREFCNT_dec(listsv);
2547*0Sstevel@tonic-gate if (transv)
2548*0Sstevel@tonic-gate SvREFCNT_dec(transv);
2549*0Sstevel@tonic-gate
2550*0Sstevel@tonic-gate if (!del && havefinal && rlen)
2551*0Sstevel@tonic-gate (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2552*0Sstevel@tonic-gate newSVuv((UV)final), 0);
2553*0Sstevel@tonic-gate
2554*0Sstevel@tonic-gate if (grows)
2555*0Sstevel@tonic-gate o->op_private |= OPpTRANS_GROWS;
2556*0Sstevel@tonic-gate
2557*0Sstevel@tonic-gate if (tsave)
2558*0Sstevel@tonic-gate Safefree(tsave);
2559*0Sstevel@tonic-gate if (rsave)
2560*0Sstevel@tonic-gate Safefree(rsave);
2561*0Sstevel@tonic-gate
2562*0Sstevel@tonic-gate op_free(expr);
2563*0Sstevel@tonic-gate op_free(repl);
2564*0Sstevel@tonic-gate return o;
2565*0Sstevel@tonic-gate }
2566*0Sstevel@tonic-gate
2567*0Sstevel@tonic-gate tbl = (short*)cPVOPo->op_pv;
2568*0Sstevel@tonic-gate if (complement) {
2569*0Sstevel@tonic-gate Zero(tbl, 256, short);
2570*0Sstevel@tonic-gate for (i = 0; i < (I32)tlen; i++)
2571*0Sstevel@tonic-gate tbl[t[i]] = -1;
2572*0Sstevel@tonic-gate for (i = 0, j = 0; i < 256; i++) {
2573*0Sstevel@tonic-gate if (!tbl[i]) {
2574*0Sstevel@tonic-gate if (j >= (I32)rlen) {
2575*0Sstevel@tonic-gate if (del)
2576*0Sstevel@tonic-gate tbl[i] = -2;
2577*0Sstevel@tonic-gate else if (rlen)
2578*0Sstevel@tonic-gate tbl[i] = r[j-1];
2579*0Sstevel@tonic-gate else
2580*0Sstevel@tonic-gate tbl[i] = (short)i;
2581*0Sstevel@tonic-gate }
2582*0Sstevel@tonic-gate else {
2583*0Sstevel@tonic-gate if (i < 128 && r[j] >= 128)
2584*0Sstevel@tonic-gate grows = 1;
2585*0Sstevel@tonic-gate tbl[i] = r[j++];
2586*0Sstevel@tonic-gate }
2587*0Sstevel@tonic-gate }
2588*0Sstevel@tonic-gate }
2589*0Sstevel@tonic-gate if (!del) {
2590*0Sstevel@tonic-gate if (!rlen) {
2591*0Sstevel@tonic-gate j = rlen;
2592*0Sstevel@tonic-gate if (!squash)
2593*0Sstevel@tonic-gate o->op_private |= OPpTRANS_IDENTICAL;
2594*0Sstevel@tonic-gate }
2595*0Sstevel@tonic-gate else if (j >= (I32)rlen)
2596*0Sstevel@tonic-gate j = rlen - 1;
2597*0Sstevel@tonic-gate else
2598*0Sstevel@tonic-gate cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2599*0Sstevel@tonic-gate tbl[0x100] = rlen - j;
2600*0Sstevel@tonic-gate for (i=0; i < (I32)rlen - j; i++)
2601*0Sstevel@tonic-gate tbl[0x101+i] = r[j+i];
2602*0Sstevel@tonic-gate }
2603*0Sstevel@tonic-gate }
2604*0Sstevel@tonic-gate else {
2605*0Sstevel@tonic-gate if (!rlen && !del) {
2606*0Sstevel@tonic-gate r = t; rlen = tlen;
2607*0Sstevel@tonic-gate if (!squash)
2608*0Sstevel@tonic-gate o->op_private |= OPpTRANS_IDENTICAL;
2609*0Sstevel@tonic-gate }
2610*0Sstevel@tonic-gate else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2611*0Sstevel@tonic-gate o->op_private |= OPpTRANS_IDENTICAL;
2612*0Sstevel@tonic-gate }
2613*0Sstevel@tonic-gate for (i = 0; i < 256; i++)
2614*0Sstevel@tonic-gate tbl[i] = -1;
2615*0Sstevel@tonic-gate for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2616*0Sstevel@tonic-gate if (j >= (I32)rlen) {
2617*0Sstevel@tonic-gate if (del) {
2618*0Sstevel@tonic-gate if (tbl[t[i]] == -1)
2619*0Sstevel@tonic-gate tbl[t[i]] = -2;
2620*0Sstevel@tonic-gate continue;
2621*0Sstevel@tonic-gate }
2622*0Sstevel@tonic-gate --j;
2623*0Sstevel@tonic-gate }
2624*0Sstevel@tonic-gate if (tbl[t[i]] == -1) {
2625*0Sstevel@tonic-gate if (t[i] < 128 && r[j] >= 128)
2626*0Sstevel@tonic-gate grows = 1;
2627*0Sstevel@tonic-gate tbl[t[i]] = r[j];
2628*0Sstevel@tonic-gate }
2629*0Sstevel@tonic-gate }
2630*0Sstevel@tonic-gate }
2631*0Sstevel@tonic-gate if (grows)
2632*0Sstevel@tonic-gate o->op_private |= OPpTRANS_GROWS;
2633*0Sstevel@tonic-gate op_free(expr);
2634*0Sstevel@tonic-gate op_free(repl);
2635*0Sstevel@tonic-gate
2636*0Sstevel@tonic-gate return o;
2637*0Sstevel@tonic-gate }
2638*0Sstevel@tonic-gate
2639*0Sstevel@tonic-gate OP *
Perl_newPMOP(pTHX_ I32 type,I32 flags)2640*0Sstevel@tonic-gate Perl_newPMOP(pTHX_ I32 type, I32 flags)
2641*0Sstevel@tonic-gate {
2642*0Sstevel@tonic-gate PMOP *pmop;
2643*0Sstevel@tonic-gate
2644*0Sstevel@tonic-gate NewOp(1101, pmop, 1, PMOP);
2645*0Sstevel@tonic-gate pmop->op_type = (OPCODE)type;
2646*0Sstevel@tonic-gate pmop->op_ppaddr = PL_ppaddr[type];
2647*0Sstevel@tonic-gate pmop->op_flags = (U8)flags;
2648*0Sstevel@tonic-gate pmop->op_private = (U8)(0 | (flags >> 8));
2649*0Sstevel@tonic-gate
2650*0Sstevel@tonic-gate if (PL_hints & HINT_RE_TAINT)
2651*0Sstevel@tonic-gate pmop->op_pmpermflags |= PMf_RETAINT;
2652*0Sstevel@tonic-gate if (PL_hints & HINT_LOCALE)
2653*0Sstevel@tonic-gate pmop->op_pmpermflags |= PMf_LOCALE;
2654*0Sstevel@tonic-gate pmop->op_pmflags = pmop->op_pmpermflags;
2655*0Sstevel@tonic-gate
2656*0Sstevel@tonic-gate #ifdef USE_ITHREADS
2657*0Sstevel@tonic-gate {
2658*0Sstevel@tonic-gate SV* repointer;
2659*0Sstevel@tonic-gate if(av_len((AV*) PL_regex_pad[0]) > -1) {
2660*0Sstevel@tonic-gate repointer = av_pop((AV*)PL_regex_pad[0]);
2661*0Sstevel@tonic-gate pmop->op_pmoffset = SvIV(repointer);
2662*0Sstevel@tonic-gate SvREPADTMP_off(repointer);
2663*0Sstevel@tonic-gate sv_setiv(repointer,0);
2664*0Sstevel@tonic-gate } else {
2665*0Sstevel@tonic-gate repointer = newSViv(0);
2666*0Sstevel@tonic-gate av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2667*0Sstevel@tonic-gate pmop->op_pmoffset = av_len(PL_regex_padav);
2668*0Sstevel@tonic-gate PL_regex_pad = AvARRAY(PL_regex_padav);
2669*0Sstevel@tonic-gate }
2670*0Sstevel@tonic-gate }
2671*0Sstevel@tonic-gate #endif
2672*0Sstevel@tonic-gate
2673*0Sstevel@tonic-gate /* link into pm list */
2674*0Sstevel@tonic-gate if (type != OP_TRANS && PL_curstash) {
2675*0Sstevel@tonic-gate pmop->op_pmnext = HvPMROOT(PL_curstash);
2676*0Sstevel@tonic-gate HvPMROOT(PL_curstash) = pmop;
2677*0Sstevel@tonic-gate PmopSTASH_set(pmop,PL_curstash);
2678*0Sstevel@tonic-gate }
2679*0Sstevel@tonic-gate
2680*0Sstevel@tonic-gate return CHECKOP(type, pmop);
2681*0Sstevel@tonic-gate }
2682*0Sstevel@tonic-gate
2683*0Sstevel@tonic-gate OP *
Perl_pmruntime(pTHX_ OP * o,OP * expr,OP * repl)2684*0Sstevel@tonic-gate Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2685*0Sstevel@tonic-gate {
2686*0Sstevel@tonic-gate PMOP *pm;
2687*0Sstevel@tonic-gate LOGOP *rcop;
2688*0Sstevel@tonic-gate I32 repl_has_vars = 0;
2689*0Sstevel@tonic-gate
2690*0Sstevel@tonic-gate if (o->op_type == OP_TRANS)
2691*0Sstevel@tonic-gate return pmtrans(o, expr, repl);
2692*0Sstevel@tonic-gate
2693*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE;
2694*0Sstevel@tonic-gate pm = (PMOP*)o;
2695*0Sstevel@tonic-gate
2696*0Sstevel@tonic-gate if (expr->op_type == OP_CONST) {
2697*0Sstevel@tonic-gate STRLEN plen;
2698*0Sstevel@tonic-gate SV *pat = ((SVOP*)expr)->op_sv;
2699*0Sstevel@tonic-gate char *p = SvPV(pat, plen);
2700*0Sstevel@tonic-gate if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2701*0Sstevel@tonic-gate sv_setpvn(pat, "\\s+", 3);
2702*0Sstevel@tonic-gate p = SvPV(pat, plen);
2703*0Sstevel@tonic-gate pm->op_pmflags |= PMf_SKIPWHITE;
2704*0Sstevel@tonic-gate }
2705*0Sstevel@tonic-gate if (DO_UTF8(pat))
2706*0Sstevel@tonic-gate pm->op_pmdynflags |= PMdf_UTF8;
2707*0Sstevel@tonic-gate PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
2708*0Sstevel@tonic-gate if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2709*0Sstevel@tonic-gate pm->op_pmflags |= PMf_WHITE;
2710*0Sstevel@tonic-gate op_free(expr);
2711*0Sstevel@tonic-gate }
2712*0Sstevel@tonic-gate else {
2713*0Sstevel@tonic-gate if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2714*0Sstevel@tonic-gate expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2715*0Sstevel@tonic-gate ? OP_REGCRESET
2716*0Sstevel@tonic-gate : OP_REGCMAYBE),0,expr);
2717*0Sstevel@tonic-gate
2718*0Sstevel@tonic-gate NewOp(1101, rcop, 1, LOGOP);
2719*0Sstevel@tonic-gate rcop->op_type = OP_REGCOMP;
2720*0Sstevel@tonic-gate rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2721*0Sstevel@tonic-gate rcop->op_first = scalar(expr);
2722*0Sstevel@tonic-gate rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2723*0Sstevel@tonic-gate ? (OPf_SPECIAL | OPf_KIDS)
2724*0Sstevel@tonic-gate : OPf_KIDS);
2725*0Sstevel@tonic-gate rcop->op_private = 1;
2726*0Sstevel@tonic-gate rcop->op_other = o;
2727*0Sstevel@tonic-gate
2728*0Sstevel@tonic-gate /* establish postfix order */
2729*0Sstevel@tonic-gate if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2730*0Sstevel@tonic-gate LINKLIST(expr);
2731*0Sstevel@tonic-gate rcop->op_next = expr;
2732*0Sstevel@tonic-gate ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2733*0Sstevel@tonic-gate }
2734*0Sstevel@tonic-gate else {
2735*0Sstevel@tonic-gate rcop->op_next = LINKLIST(expr);
2736*0Sstevel@tonic-gate expr->op_next = (OP*)rcop;
2737*0Sstevel@tonic-gate }
2738*0Sstevel@tonic-gate
2739*0Sstevel@tonic-gate prepend_elem(o->op_type, scalar((OP*)rcop), o);
2740*0Sstevel@tonic-gate }
2741*0Sstevel@tonic-gate
2742*0Sstevel@tonic-gate if (repl) {
2743*0Sstevel@tonic-gate OP *curop;
2744*0Sstevel@tonic-gate if (pm->op_pmflags & PMf_EVAL) {
2745*0Sstevel@tonic-gate curop = 0;
2746*0Sstevel@tonic-gate if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2747*0Sstevel@tonic-gate CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2748*0Sstevel@tonic-gate }
2749*0Sstevel@tonic-gate #ifdef USE_5005THREADS
2750*0Sstevel@tonic-gate else if (repl->op_type == OP_THREADSV
2751*0Sstevel@tonic-gate && strchr("&`'123456789+",
2752*0Sstevel@tonic-gate PL_threadsv_names[repl->op_targ]))
2753*0Sstevel@tonic-gate {
2754*0Sstevel@tonic-gate curop = 0;
2755*0Sstevel@tonic-gate }
2756*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
2757*0Sstevel@tonic-gate else if (repl->op_type == OP_CONST)
2758*0Sstevel@tonic-gate curop = repl;
2759*0Sstevel@tonic-gate else {
2760*0Sstevel@tonic-gate OP *lastop = 0;
2761*0Sstevel@tonic-gate for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2762*0Sstevel@tonic-gate if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2763*0Sstevel@tonic-gate #ifdef USE_5005THREADS
2764*0Sstevel@tonic-gate if (curop->op_type == OP_THREADSV) {
2765*0Sstevel@tonic-gate repl_has_vars = 1;
2766*0Sstevel@tonic-gate if (strchr("&`'123456789+", curop->op_private))
2767*0Sstevel@tonic-gate break;
2768*0Sstevel@tonic-gate }
2769*0Sstevel@tonic-gate #else
2770*0Sstevel@tonic-gate if (curop->op_type == OP_GV) {
2771*0Sstevel@tonic-gate GV *gv = cGVOPx_gv(curop);
2772*0Sstevel@tonic-gate repl_has_vars = 1;
2773*0Sstevel@tonic-gate if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2774*0Sstevel@tonic-gate break;
2775*0Sstevel@tonic-gate }
2776*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
2777*0Sstevel@tonic-gate else if (curop->op_type == OP_RV2CV)
2778*0Sstevel@tonic-gate break;
2779*0Sstevel@tonic-gate else if (curop->op_type == OP_RV2SV ||
2780*0Sstevel@tonic-gate curop->op_type == OP_RV2AV ||
2781*0Sstevel@tonic-gate curop->op_type == OP_RV2HV ||
2782*0Sstevel@tonic-gate curop->op_type == OP_RV2GV) {
2783*0Sstevel@tonic-gate if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2784*0Sstevel@tonic-gate break;
2785*0Sstevel@tonic-gate }
2786*0Sstevel@tonic-gate else if (curop->op_type == OP_PADSV ||
2787*0Sstevel@tonic-gate curop->op_type == OP_PADAV ||
2788*0Sstevel@tonic-gate curop->op_type == OP_PADHV ||
2789*0Sstevel@tonic-gate curop->op_type == OP_PADANY) {
2790*0Sstevel@tonic-gate repl_has_vars = 1;
2791*0Sstevel@tonic-gate }
2792*0Sstevel@tonic-gate else if (curop->op_type == OP_PUSHRE)
2793*0Sstevel@tonic-gate ; /* Okay here, dangerous in newASSIGNOP */
2794*0Sstevel@tonic-gate else
2795*0Sstevel@tonic-gate break;
2796*0Sstevel@tonic-gate }
2797*0Sstevel@tonic-gate lastop = curop;
2798*0Sstevel@tonic-gate }
2799*0Sstevel@tonic-gate }
2800*0Sstevel@tonic-gate if (curop == repl
2801*0Sstevel@tonic-gate && !(repl_has_vars
2802*0Sstevel@tonic-gate && (!PM_GETRE(pm)
2803*0Sstevel@tonic-gate || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2804*0Sstevel@tonic-gate pm->op_pmflags |= PMf_CONST; /* const for long enough */
2805*0Sstevel@tonic-gate pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2806*0Sstevel@tonic-gate prepend_elem(o->op_type, scalar(repl), o);
2807*0Sstevel@tonic-gate }
2808*0Sstevel@tonic-gate else {
2809*0Sstevel@tonic-gate if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2810*0Sstevel@tonic-gate pm->op_pmflags |= PMf_MAYBE_CONST;
2811*0Sstevel@tonic-gate pm->op_pmpermflags |= PMf_MAYBE_CONST;
2812*0Sstevel@tonic-gate }
2813*0Sstevel@tonic-gate NewOp(1101, rcop, 1, LOGOP);
2814*0Sstevel@tonic-gate rcop->op_type = OP_SUBSTCONT;
2815*0Sstevel@tonic-gate rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2816*0Sstevel@tonic-gate rcop->op_first = scalar(repl);
2817*0Sstevel@tonic-gate rcop->op_flags |= OPf_KIDS;
2818*0Sstevel@tonic-gate rcop->op_private = 1;
2819*0Sstevel@tonic-gate rcop->op_other = o;
2820*0Sstevel@tonic-gate
2821*0Sstevel@tonic-gate /* establish postfix order */
2822*0Sstevel@tonic-gate rcop->op_next = LINKLIST(repl);
2823*0Sstevel@tonic-gate repl->op_next = (OP*)rcop;
2824*0Sstevel@tonic-gate
2825*0Sstevel@tonic-gate pm->op_pmreplroot = scalar((OP*)rcop);
2826*0Sstevel@tonic-gate pm->op_pmreplstart = LINKLIST(rcop);
2827*0Sstevel@tonic-gate rcop->op_next = 0;
2828*0Sstevel@tonic-gate }
2829*0Sstevel@tonic-gate }
2830*0Sstevel@tonic-gate
2831*0Sstevel@tonic-gate return (OP*)pm;
2832*0Sstevel@tonic-gate }
2833*0Sstevel@tonic-gate
2834*0Sstevel@tonic-gate OP *
Perl_newSVOP(pTHX_ I32 type,I32 flags,SV * sv)2835*0Sstevel@tonic-gate Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2836*0Sstevel@tonic-gate {
2837*0Sstevel@tonic-gate SVOP *svop;
2838*0Sstevel@tonic-gate NewOp(1101, svop, 1, SVOP);
2839*0Sstevel@tonic-gate svop->op_type = (OPCODE)type;
2840*0Sstevel@tonic-gate svop->op_ppaddr = PL_ppaddr[type];
2841*0Sstevel@tonic-gate svop->op_sv = sv;
2842*0Sstevel@tonic-gate svop->op_next = (OP*)svop;
2843*0Sstevel@tonic-gate svop->op_flags = (U8)flags;
2844*0Sstevel@tonic-gate if (PL_opargs[type] & OA_RETSCALAR)
2845*0Sstevel@tonic-gate scalar((OP*)svop);
2846*0Sstevel@tonic-gate if (PL_opargs[type] & OA_TARGET)
2847*0Sstevel@tonic-gate svop->op_targ = pad_alloc(type, SVs_PADTMP);
2848*0Sstevel@tonic-gate return CHECKOP(type, svop);
2849*0Sstevel@tonic-gate }
2850*0Sstevel@tonic-gate
2851*0Sstevel@tonic-gate OP *
Perl_newPADOP(pTHX_ I32 type,I32 flags,SV * sv)2852*0Sstevel@tonic-gate Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2853*0Sstevel@tonic-gate {
2854*0Sstevel@tonic-gate PADOP *padop;
2855*0Sstevel@tonic-gate NewOp(1101, padop, 1, PADOP);
2856*0Sstevel@tonic-gate padop->op_type = (OPCODE)type;
2857*0Sstevel@tonic-gate padop->op_ppaddr = PL_ppaddr[type];
2858*0Sstevel@tonic-gate padop->op_padix = pad_alloc(type, SVs_PADTMP);
2859*0Sstevel@tonic-gate SvREFCNT_dec(PAD_SVl(padop->op_padix));
2860*0Sstevel@tonic-gate PAD_SETSV(padop->op_padix, sv);
2861*0Sstevel@tonic-gate if (sv)
2862*0Sstevel@tonic-gate SvPADTMP_on(sv);
2863*0Sstevel@tonic-gate padop->op_next = (OP*)padop;
2864*0Sstevel@tonic-gate padop->op_flags = (U8)flags;
2865*0Sstevel@tonic-gate if (PL_opargs[type] & OA_RETSCALAR)
2866*0Sstevel@tonic-gate scalar((OP*)padop);
2867*0Sstevel@tonic-gate if (PL_opargs[type] & OA_TARGET)
2868*0Sstevel@tonic-gate padop->op_targ = pad_alloc(type, SVs_PADTMP);
2869*0Sstevel@tonic-gate return CHECKOP(type, padop);
2870*0Sstevel@tonic-gate }
2871*0Sstevel@tonic-gate
2872*0Sstevel@tonic-gate OP *
Perl_newGVOP(pTHX_ I32 type,I32 flags,GV * gv)2873*0Sstevel@tonic-gate Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2874*0Sstevel@tonic-gate {
2875*0Sstevel@tonic-gate #ifdef USE_ITHREADS
2876*0Sstevel@tonic-gate if (gv)
2877*0Sstevel@tonic-gate GvIN_PAD_on(gv);
2878*0Sstevel@tonic-gate return newPADOP(type, flags, SvREFCNT_inc(gv));
2879*0Sstevel@tonic-gate #else
2880*0Sstevel@tonic-gate return newSVOP(type, flags, SvREFCNT_inc(gv));
2881*0Sstevel@tonic-gate #endif
2882*0Sstevel@tonic-gate }
2883*0Sstevel@tonic-gate
2884*0Sstevel@tonic-gate OP *
Perl_newPVOP(pTHX_ I32 type,I32 flags,char * pv)2885*0Sstevel@tonic-gate Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2886*0Sstevel@tonic-gate {
2887*0Sstevel@tonic-gate PVOP *pvop;
2888*0Sstevel@tonic-gate NewOp(1101, pvop, 1, PVOP);
2889*0Sstevel@tonic-gate pvop->op_type = (OPCODE)type;
2890*0Sstevel@tonic-gate pvop->op_ppaddr = PL_ppaddr[type];
2891*0Sstevel@tonic-gate pvop->op_pv = pv;
2892*0Sstevel@tonic-gate pvop->op_next = (OP*)pvop;
2893*0Sstevel@tonic-gate pvop->op_flags = (U8)flags;
2894*0Sstevel@tonic-gate if (PL_opargs[type] & OA_RETSCALAR)
2895*0Sstevel@tonic-gate scalar((OP*)pvop);
2896*0Sstevel@tonic-gate if (PL_opargs[type] & OA_TARGET)
2897*0Sstevel@tonic-gate pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2898*0Sstevel@tonic-gate return CHECKOP(type, pvop);
2899*0Sstevel@tonic-gate }
2900*0Sstevel@tonic-gate
2901*0Sstevel@tonic-gate void
Perl_package(pTHX_ OP * o)2902*0Sstevel@tonic-gate Perl_package(pTHX_ OP *o)
2903*0Sstevel@tonic-gate {
2904*0Sstevel@tonic-gate SV *sv;
2905*0Sstevel@tonic-gate
2906*0Sstevel@tonic-gate save_hptr(&PL_curstash);
2907*0Sstevel@tonic-gate save_item(PL_curstname);
2908*0Sstevel@tonic-gate if (o) {
2909*0Sstevel@tonic-gate STRLEN len;
2910*0Sstevel@tonic-gate char *name;
2911*0Sstevel@tonic-gate sv = cSVOPo->op_sv;
2912*0Sstevel@tonic-gate name = SvPV(sv, len);
2913*0Sstevel@tonic-gate PL_curstash = gv_stashpvn(name,len,TRUE);
2914*0Sstevel@tonic-gate sv_setpvn(PL_curstname, name, len);
2915*0Sstevel@tonic-gate op_free(o);
2916*0Sstevel@tonic-gate }
2917*0Sstevel@tonic-gate else {
2918*0Sstevel@tonic-gate deprecate("\"package\" with no arguments");
2919*0Sstevel@tonic-gate sv_setpv(PL_curstname,"<none>");
2920*0Sstevel@tonic-gate PL_curstash = Nullhv;
2921*0Sstevel@tonic-gate }
2922*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE;
2923*0Sstevel@tonic-gate PL_copline = NOLINE;
2924*0Sstevel@tonic-gate PL_expect = XSTATE;
2925*0Sstevel@tonic-gate }
2926*0Sstevel@tonic-gate
2927*0Sstevel@tonic-gate void
Perl_utilize(pTHX_ int aver,I32 floor,OP * version,OP * idop,OP * arg)2928*0Sstevel@tonic-gate Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
2929*0Sstevel@tonic-gate {
2930*0Sstevel@tonic-gate OP *pack;
2931*0Sstevel@tonic-gate OP *imop;
2932*0Sstevel@tonic-gate OP *veop;
2933*0Sstevel@tonic-gate
2934*0Sstevel@tonic-gate if (idop->op_type != OP_CONST)
2935*0Sstevel@tonic-gate Perl_croak(aTHX_ "Module name must be constant");
2936*0Sstevel@tonic-gate
2937*0Sstevel@tonic-gate veop = Nullop;
2938*0Sstevel@tonic-gate
2939*0Sstevel@tonic-gate if (version != Nullop) {
2940*0Sstevel@tonic-gate SV *vesv = ((SVOP*)version)->op_sv;
2941*0Sstevel@tonic-gate
2942*0Sstevel@tonic-gate if (arg == Nullop && !SvNIOKp(vesv)) {
2943*0Sstevel@tonic-gate arg = version;
2944*0Sstevel@tonic-gate }
2945*0Sstevel@tonic-gate else {
2946*0Sstevel@tonic-gate OP *pack;
2947*0Sstevel@tonic-gate SV *meth;
2948*0Sstevel@tonic-gate
2949*0Sstevel@tonic-gate if (version->op_type != OP_CONST || !SvNIOKp(vesv))
2950*0Sstevel@tonic-gate Perl_croak(aTHX_ "Version number must be constant number");
2951*0Sstevel@tonic-gate
2952*0Sstevel@tonic-gate /* Make copy of idop so we don't free it twice */
2953*0Sstevel@tonic-gate pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2954*0Sstevel@tonic-gate
2955*0Sstevel@tonic-gate /* Fake up a method call to VERSION */
2956*0Sstevel@tonic-gate meth = newSVpvn("VERSION",7);
2957*0Sstevel@tonic-gate sv_upgrade(meth, SVt_PVIV);
2958*0Sstevel@tonic-gate (void)SvIOK_on(meth);
2959*0Sstevel@tonic-gate PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2960*0Sstevel@tonic-gate veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2961*0Sstevel@tonic-gate append_elem(OP_LIST,
2962*0Sstevel@tonic-gate prepend_elem(OP_LIST, pack, list(version)),
2963*0Sstevel@tonic-gate newSVOP(OP_METHOD_NAMED, 0, meth)));
2964*0Sstevel@tonic-gate }
2965*0Sstevel@tonic-gate }
2966*0Sstevel@tonic-gate
2967*0Sstevel@tonic-gate /* Fake up an import/unimport */
2968*0Sstevel@tonic-gate if (arg && arg->op_type == OP_STUB)
2969*0Sstevel@tonic-gate imop = arg; /* no import on explicit () */
2970*0Sstevel@tonic-gate else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
2971*0Sstevel@tonic-gate imop = Nullop; /* use 5.0; */
2972*0Sstevel@tonic-gate }
2973*0Sstevel@tonic-gate else {
2974*0Sstevel@tonic-gate SV *meth;
2975*0Sstevel@tonic-gate
2976*0Sstevel@tonic-gate /* Make copy of idop so we don't free it twice */
2977*0Sstevel@tonic-gate pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
2978*0Sstevel@tonic-gate
2979*0Sstevel@tonic-gate /* Fake up a method call to import/unimport */
2980*0Sstevel@tonic-gate meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
2981*0Sstevel@tonic-gate (void)SvUPGRADE(meth, SVt_PVIV);
2982*0Sstevel@tonic-gate (void)SvIOK_on(meth);
2983*0Sstevel@tonic-gate PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
2984*0Sstevel@tonic-gate imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2985*0Sstevel@tonic-gate append_elem(OP_LIST,
2986*0Sstevel@tonic-gate prepend_elem(OP_LIST, pack, list(arg)),
2987*0Sstevel@tonic-gate newSVOP(OP_METHOD_NAMED, 0, meth)));
2988*0Sstevel@tonic-gate }
2989*0Sstevel@tonic-gate
2990*0Sstevel@tonic-gate /* Fake up the BEGIN {}, which does its thing immediately. */
2991*0Sstevel@tonic-gate newATTRSUB(floor,
2992*0Sstevel@tonic-gate newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
2993*0Sstevel@tonic-gate Nullop,
2994*0Sstevel@tonic-gate Nullop,
2995*0Sstevel@tonic-gate append_elem(OP_LINESEQ,
2996*0Sstevel@tonic-gate append_elem(OP_LINESEQ,
2997*0Sstevel@tonic-gate newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
2998*0Sstevel@tonic-gate newSTATEOP(0, Nullch, veop)),
2999*0Sstevel@tonic-gate newSTATEOP(0, Nullch, imop) ));
3000*0Sstevel@tonic-gate
3001*0Sstevel@tonic-gate /* The "did you use incorrect case?" warning used to be here.
3002*0Sstevel@tonic-gate * The problem is that on case-insensitive filesystems one
3003*0Sstevel@tonic-gate * might get false positives for "use" (and "require"):
3004*0Sstevel@tonic-gate * "use Strict" or "require CARP" will work. This causes
3005*0Sstevel@tonic-gate * portability problems for the script: in case-strict
3006*0Sstevel@tonic-gate * filesystems the script will stop working.
3007*0Sstevel@tonic-gate *
3008*0Sstevel@tonic-gate * The "incorrect case" warning checked whether "use Foo"
3009*0Sstevel@tonic-gate * imported "Foo" to your namespace, but that is wrong, too:
3010*0Sstevel@tonic-gate * there is no requirement nor promise in the language that
3011*0Sstevel@tonic-gate * a Foo.pm should or would contain anything in package "Foo".
3012*0Sstevel@tonic-gate *
3013*0Sstevel@tonic-gate * There is very little Configure-wise that can be done, either:
3014*0Sstevel@tonic-gate * the case-sensitivity of the build filesystem of Perl does not
3015*0Sstevel@tonic-gate * help in guessing the case-sensitivity of the runtime environment.
3016*0Sstevel@tonic-gate */
3017*0Sstevel@tonic-gate
3018*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE;
3019*0Sstevel@tonic-gate PL_copline = NOLINE;
3020*0Sstevel@tonic-gate PL_expect = XSTATE;
3021*0Sstevel@tonic-gate PL_cop_seqmax++; /* Purely for B::*'s benefit */
3022*0Sstevel@tonic-gate }
3023*0Sstevel@tonic-gate
3024*0Sstevel@tonic-gate /*
3025*0Sstevel@tonic-gate =head1 Embedding Functions
3026*0Sstevel@tonic-gate
3027*0Sstevel@tonic-gate =for apidoc load_module
3028*0Sstevel@tonic-gate
3029*0Sstevel@tonic-gate Loads the module whose name is pointed to by the string part of name.
3030*0Sstevel@tonic-gate Note that the actual module name, not its filename, should be given.
3031*0Sstevel@tonic-gate Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3032*0Sstevel@tonic-gate PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3033*0Sstevel@tonic-gate (or 0 for no flags). ver, if specified, provides version semantics
3034*0Sstevel@tonic-gate similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3035*0Sstevel@tonic-gate arguments can be used to specify arguments to the module's import()
3036*0Sstevel@tonic-gate method, similar to C<use Foo::Bar VERSION LIST>.
3037*0Sstevel@tonic-gate
3038*0Sstevel@tonic-gate =cut */
3039*0Sstevel@tonic-gate
3040*0Sstevel@tonic-gate void
Perl_load_module(pTHX_ U32 flags,SV * name,SV * ver,...)3041*0Sstevel@tonic-gate Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3042*0Sstevel@tonic-gate {
3043*0Sstevel@tonic-gate va_list args;
3044*0Sstevel@tonic-gate va_start(args, ver);
3045*0Sstevel@tonic-gate vload_module(flags, name, ver, &args);
3046*0Sstevel@tonic-gate va_end(args);
3047*0Sstevel@tonic-gate }
3048*0Sstevel@tonic-gate
3049*0Sstevel@tonic-gate #ifdef PERL_IMPLICIT_CONTEXT
3050*0Sstevel@tonic-gate void
Perl_load_module_nocontext(U32 flags,SV * name,SV * ver,...)3051*0Sstevel@tonic-gate Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3052*0Sstevel@tonic-gate {
3053*0Sstevel@tonic-gate dTHX;
3054*0Sstevel@tonic-gate va_list args;
3055*0Sstevel@tonic-gate va_start(args, ver);
3056*0Sstevel@tonic-gate vload_module(flags, name, ver, &args);
3057*0Sstevel@tonic-gate va_end(args);
3058*0Sstevel@tonic-gate }
3059*0Sstevel@tonic-gate #endif
3060*0Sstevel@tonic-gate
3061*0Sstevel@tonic-gate void
Perl_vload_module(pTHX_ U32 flags,SV * name,SV * ver,va_list * args)3062*0Sstevel@tonic-gate Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3063*0Sstevel@tonic-gate {
3064*0Sstevel@tonic-gate OP *modname, *veop, *imop;
3065*0Sstevel@tonic-gate
3066*0Sstevel@tonic-gate modname = newSVOP(OP_CONST, 0, name);
3067*0Sstevel@tonic-gate modname->op_private |= OPpCONST_BARE;
3068*0Sstevel@tonic-gate if (ver) {
3069*0Sstevel@tonic-gate veop = newSVOP(OP_CONST, 0, ver);
3070*0Sstevel@tonic-gate }
3071*0Sstevel@tonic-gate else
3072*0Sstevel@tonic-gate veop = Nullop;
3073*0Sstevel@tonic-gate if (flags & PERL_LOADMOD_NOIMPORT) {
3074*0Sstevel@tonic-gate imop = sawparens(newNULLLIST());
3075*0Sstevel@tonic-gate }
3076*0Sstevel@tonic-gate else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3077*0Sstevel@tonic-gate imop = va_arg(*args, OP*);
3078*0Sstevel@tonic-gate }
3079*0Sstevel@tonic-gate else {
3080*0Sstevel@tonic-gate SV *sv;
3081*0Sstevel@tonic-gate imop = Nullop;
3082*0Sstevel@tonic-gate sv = va_arg(*args, SV*);
3083*0Sstevel@tonic-gate while (sv) {
3084*0Sstevel@tonic-gate imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3085*0Sstevel@tonic-gate sv = va_arg(*args, SV*);
3086*0Sstevel@tonic-gate }
3087*0Sstevel@tonic-gate }
3088*0Sstevel@tonic-gate {
3089*0Sstevel@tonic-gate line_t ocopline = PL_copline;
3090*0Sstevel@tonic-gate COP *ocurcop = PL_curcop;
3091*0Sstevel@tonic-gate int oexpect = PL_expect;
3092*0Sstevel@tonic-gate
3093*0Sstevel@tonic-gate utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3094*0Sstevel@tonic-gate veop, modname, imop);
3095*0Sstevel@tonic-gate PL_expect = oexpect;
3096*0Sstevel@tonic-gate PL_copline = ocopline;
3097*0Sstevel@tonic-gate PL_curcop = ocurcop;
3098*0Sstevel@tonic-gate }
3099*0Sstevel@tonic-gate }
3100*0Sstevel@tonic-gate
3101*0Sstevel@tonic-gate OP *
Perl_dofile(pTHX_ OP * term)3102*0Sstevel@tonic-gate Perl_dofile(pTHX_ OP *term)
3103*0Sstevel@tonic-gate {
3104*0Sstevel@tonic-gate OP *doop;
3105*0Sstevel@tonic-gate GV *gv;
3106*0Sstevel@tonic-gate
3107*0Sstevel@tonic-gate gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3108*0Sstevel@tonic-gate if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3109*0Sstevel@tonic-gate gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3110*0Sstevel@tonic-gate
3111*0Sstevel@tonic-gate if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3112*0Sstevel@tonic-gate doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3113*0Sstevel@tonic-gate append_elem(OP_LIST, term,
3114*0Sstevel@tonic-gate scalar(newUNOP(OP_RV2CV, 0,
3115*0Sstevel@tonic-gate newGVOP(OP_GV, 0,
3116*0Sstevel@tonic-gate gv))))));
3117*0Sstevel@tonic-gate }
3118*0Sstevel@tonic-gate else {
3119*0Sstevel@tonic-gate doop = newUNOP(OP_DOFILE, 0, scalar(term));
3120*0Sstevel@tonic-gate }
3121*0Sstevel@tonic-gate return doop;
3122*0Sstevel@tonic-gate }
3123*0Sstevel@tonic-gate
3124*0Sstevel@tonic-gate OP *
Perl_newSLICEOP(pTHX_ I32 flags,OP * subscript,OP * listval)3125*0Sstevel@tonic-gate Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3126*0Sstevel@tonic-gate {
3127*0Sstevel@tonic-gate return newBINOP(OP_LSLICE, flags,
3128*0Sstevel@tonic-gate list(force_list(subscript)),
3129*0Sstevel@tonic-gate list(force_list(listval)) );
3130*0Sstevel@tonic-gate }
3131*0Sstevel@tonic-gate
3132*0Sstevel@tonic-gate STATIC I32
S_list_assignment(pTHX_ register OP * o)3133*0Sstevel@tonic-gate S_list_assignment(pTHX_ register OP *o)
3134*0Sstevel@tonic-gate {
3135*0Sstevel@tonic-gate if (!o)
3136*0Sstevel@tonic-gate return TRUE;
3137*0Sstevel@tonic-gate
3138*0Sstevel@tonic-gate if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3139*0Sstevel@tonic-gate o = cUNOPo->op_first;
3140*0Sstevel@tonic-gate
3141*0Sstevel@tonic-gate if (o->op_type == OP_COND_EXPR) {
3142*0Sstevel@tonic-gate I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3143*0Sstevel@tonic-gate I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3144*0Sstevel@tonic-gate
3145*0Sstevel@tonic-gate if (t && f)
3146*0Sstevel@tonic-gate return TRUE;
3147*0Sstevel@tonic-gate if (t || f)
3148*0Sstevel@tonic-gate yyerror("Assignment to both a list and a scalar");
3149*0Sstevel@tonic-gate return FALSE;
3150*0Sstevel@tonic-gate }
3151*0Sstevel@tonic-gate
3152*0Sstevel@tonic-gate if (o->op_type == OP_LIST &&
3153*0Sstevel@tonic-gate (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3154*0Sstevel@tonic-gate o->op_private & OPpLVAL_INTRO)
3155*0Sstevel@tonic-gate return FALSE;
3156*0Sstevel@tonic-gate
3157*0Sstevel@tonic-gate if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3158*0Sstevel@tonic-gate o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3159*0Sstevel@tonic-gate o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3160*0Sstevel@tonic-gate return TRUE;
3161*0Sstevel@tonic-gate
3162*0Sstevel@tonic-gate if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3163*0Sstevel@tonic-gate return TRUE;
3164*0Sstevel@tonic-gate
3165*0Sstevel@tonic-gate if (o->op_type == OP_RV2SV)
3166*0Sstevel@tonic-gate return FALSE;
3167*0Sstevel@tonic-gate
3168*0Sstevel@tonic-gate return FALSE;
3169*0Sstevel@tonic-gate }
3170*0Sstevel@tonic-gate
3171*0Sstevel@tonic-gate OP *
Perl_newASSIGNOP(pTHX_ I32 flags,OP * left,I32 optype,OP * right)3172*0Sstevel@tonic-gate Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3173*0Sstevel@tonic-gate {
3174*0Sstevel@tonic-gate OP *o;
3175*0Sstevel@tonic-gate
3176*0Sstevel@tonic-gate if (optype) {
3177*0Sstevel@tonic-gate if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3178*0Sstevel@tonic-gate return newLOGOP(optype, 0,
3179*0Sstevel@tonic-gate mod(scalar(left), optype),
3180*0Sstevel@tonic-gate newUNOP(OP_SASSIGN, 0, scalar(right)));
3181*0Sstevel@tonic-gate }
3182*0Sstevel@tonic-gate else {
3183*0Sstevel@tonic-gate return newBINOP(optype, OPf_STACKED,
3184*0Sstevel@tonic-gate mod(scalar(left), optype), scalar(right));
3185*0Sstevel@tonic-gate }
3186*0Sstevel@tonic-gate }
3187*0Sstevel@tonic-gate
3188*0Sstevel@tonic-gate if (list_assignment(left)) {
3189*0Sstevel@tonic-gate OP *curop;
3190*0Sstevel@tonic-gate
3191*0Sstevel@tonic-gate PL_modcount = 0;
3192*0Sstevel@tonic-gate PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3193*0Sstevel@tonic-gate left = mod(left, OP_AASSIGN);
3194*0Sstevel@tonic-gate if (PL_eval_start)
3195*0Sstevel@tonic-gate PL_eval_start = 0;
3196*0Sstevel@tonic-gate else {
3197*0Sstevel@tonic-gate op_free(left);
3198*0Sstevel@tonic-gate op_free(right);
3199*0Sstevel@tonic-gate return Nullop;
3200*0Sstevel@tonic-gate }
3201*0Sstevel@tonic-gate /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
3202*0Sstevel@tonic-gate if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
3203*0Sstevel@tonic-gate && right->op_type == OP_STUB
3204*0Sstevel@tonic-gate && (left->op_private & OPpLVAL_INTRO))
3205*0Sstevel@tonic-gate {
3206*0Sstevel@tonic-gate op_free(right);
3207*0Sstevel@tonic-gate left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
3208*0Sstevel@tonic-gate return left;
3209*0Sstevel@tonic-gate }
3210*0Sstevel@tonic-gate curop = list(force_list(left));
3211*0Sstevel@tonic-gate o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3212*0Sstevel@tonic-gate o->op_private = (U8)(0 | (flags >> 8));
3213*0Sstevel@tonic-gate for (curop = ((LISTOP*)curop)->op_first;
3214*0Sstevel@tonic-gate curop; curop = curop->op_sibling)
3215*0Sstevel@tonic-gate {
3216*0Sstevel@tonic-gate if (curop->op_type == OP_RV2HV &&
3217*0Sstevel@tonic-gate ((UNOP*)curop)->op_first->op_type != OP_GV) {
3218*0Sstevel@tonic-gate o->op_private |= OPpASSIGN_HASH;
3219*0Sstevel@tonic-gate break;
3220*0Sstevel@tonic-gate }
3221*0Sstevel@tonic-gate }
3222*0Sstevel@tonic-gate
3223*0Sstevel@tonic-gate /* PL_generation sorcery:
3224*0Sstevel@tonic-gate * an assignment like ($a,$b) = ($c,$d) is easier than
3225*0Sstevel@tonic-gate * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3226*0Sstevel@tonic-gate * To detect whether there are common vars, the global var
3227*0Sstevel@tonic-gate * PL_generation is incremented for each assign op we compile.
3228*0Sstevel@tonic-gate * Then, while compiling the assign op, we run through all the
3229*0Sstevel@tonic-gate * variables on both sides of the assignment, setting a spare slot
3230*0Sstevel@tonic-gate * in each of them to PL_generation. If any of them already have
3231*0Sstevel@tonic-gate * that value, we know we've got commonality. We could use a
3232*0Sstevel@tonic-gate * single bit marker, but then we'd have to make 2 passes, first
3233*0Sstevel@tonic-gate * to clear the flag, then to test and set it. To find somewhere
3234*0Sstevel@tonic-gate * to store these values, evil chicanery is done with SvCUR().
3235*0Sstevel@tonic-gate */
3236*0Sstevel@tonic-gate
3237*0Sstevel@tonic-gate if (!(left->op_private & OPpLVAL_INTRO)) {
3238*0Sstevel@tonic-gate OP *lastop = o;
3239*0Sstevel@tonic-gate PL_generation++;
3240*0Sstevel@tonic-gate for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3241*0Sstevel@tonic-gate if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3242*0Sstevel@tonic-gate if (curop->op_type == OP_GV) {
3243*0Sstevel@tonic-gate GV *gv = cGVOPx_gv(curop);
3244*0Sstevel@tonic-gate if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3245*0Sstevel@tonic-gate break;
3246*0Sstevel@tonic-gate SvCUR(gv) = PL_generation;
3247*0Sstevel@tonic-gate }
3248*0Sstevel@tonic-gate else if (curop->op_type == OP_PADSV ||
3249*0Sstevel@tonic-gate curop->op_type == OP_PADAV ||
3250*0Sstevel@tonic-gate curop->op_type == OP_PADHV ||
3251*0Sstevel@tonic-gate curop->op_type == OP_PADANY)
3252*0Sstevel@tonic-gate {
3253*0Sstevel@tonic-gate if ((int)PAD_COMPNAME_GEN(curop->op_targ)
3254*0Sstevel@tonic-gate == PL_generation)
3255*0Sstevel@tonic-gate break;
3256*0Sstevel@tonic-gate PAD_COMPNAME_GEN(curop->op_targ)
3257*0Sstevel@tonic-gate = PL_generation;
3258*0Sstevel@tonic-gate
3259*0Sstevel@tonic-gate }
3260*0Sstevel@tonic-gate else if (curop->op_type == OP_RV2CV)
3261*0Sstevel@tonic-gate break;
3262*0Sstevel@tonic-gate else if (curop->op_type == OP_RV2SV ||
3263*0Sstevel@tonic-gate curop->op_type == OP_RV2AV ||
3264*0Sstevel@tonic-gate curop->op_type == OP_RV2HV ||
3265*0Sstevel@tonic-gate curop->op_type == OP_RV2GV) {
3266*0Sstevel@tonic-gate if (lastop->op_type != OP_GV) /* funny deref? */
3267*0Sstevel@tonic-gate break;
3268*0Sstevel@tonic-gate }
3269*0Sstevel@tonic-gate else if (curop->op_type == OP_PUSHRE) {
3270*0Sstevel@tonic-gate if (((PMOP*)curop)->op_pmreplroot) {
3271*0Sstevel@tonic-gate #ifdef USE_ITHREADS
3272*0Sstevel@tonic-gate GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3273*0Sstevel@tonic-gate ((PMOP*)curop)->op_pmreplroot));
3274*0Sstevel@tonic-gate #else
3275*0Sstevel@tonic-gate GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3276*0Sstevel@tonic-gate #endif
3277*0Sstevel@tonic-gate if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3278*0Sstevel@tonic-gate break;
3279*0Sstevel@tonic-gate SvCUR(gv) = PL_generation;
3280*0Sstevel@tonic-gate }
3281*0Sstevel@tonic-gate }
3282*0Sstevel@tonic-gate else
3283*0Sstevel@tonic-gate break;
3284*0Sstevel@tonic-gate }
3285*0Sstevel@tonic-gate lastop = curop;
3286*0Sstevel@tonic-gate }
3287*0Sstevel@tonic-gate if (curop != o)
3288*0Sstevel@tonic-gate o->op_private |= OPpASSIGN_COMMON;
3289*0Sstevel@tonic-gate }
3290*0Sstevel@tonic-gate if (right && right->op_type == OP_SPLIT) {
3291*0Sstevel@tonic-gate OP* tmpop;
3292*0Sstevel@tonic-gate if ((tmpop = ((LISTOP*)right)->op_first) &&
3293*0Sstevel@tonic-gate tmpop->op_type == OP_PUSHRE)
3294*0Sstevel@tonic-gate {
3295*0Sstevel@tonic-gate PMOP *pm = (PMOP*)tmpop;
3296*0Sstevel@tonic-gate if (left->op_type == OP_RV2AV &&
3297*0Sstevel@tonic-gate !(left->op_private & OPpLVAL_INTRO) &&
3298*0Sstevel@tonic-gate !(o->op_private & OPpASSIGN_COMMON) )
3299*0Sstevel@tonic-gate {
3300*0Sstevel@tonic-gate tmpop = ((UNOP*)left)->op_first;
3301*0Sstevel@tonic-gate if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3302*0Sstevel@tonic-gate #ifdef USE_ITHREADS
3303*0Sstevel@tonic-gate pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3304*0Sstevel@tonic-gate cPADOPx(tmpop)->op_padix = 0; /* steal it */
3305*0Sstevel@tonic-gate #else
3306*0Sstevel@tonic-gate pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3307*0Sstevel@tonic-gate cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3308*0Sstevel@tonic-gate #endif
3309*0Sstevel@tonic-gate pm->op_pmflags |= PMf_ONCE;
3310*0Sstevel@tonic-gate tmpop = cUNOPo->op_first; /* to list (nulled) */
3311*0Sstevel@tonic-gate tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3312*0Sstevel@tonic-gate tmpop->op_sibling = Nullop; /* don't free split */
3313*0Sstevel@tonic-gate right->op_next = tmpop->op_next; /* fix starting loc */
3314*0Sstevel@tonic-gate op_free(o); /* blow off assign */
3315*0Sstevel@tonic-gate right->op_flags &= ~OPf_WANT;
3316*0Sstevel@tonic-gate /* "I don't know and I don't care." */
3317*0Sstevel@tonic-gate return right;
3318*0Sstevel@tonic-gate }
3319*0Sstevel@tonic-gate }
3320*0Sstevel@tonic-gate else {
3321*0Sstevel@tonic-gate if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3322*0Sstevel@tonic-gate ((LISTOP*)right)->op_last->op_type == OP_CONST)
3323*0Sstevel@tonic-gate {
3324*0Sstevel@tonic-gate SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3325*0Sstevel@tonic-gate if (SvIVX(sv) == 0)
3326*0Sstevel@tonic-gate sv_setiv(sv, PL_modcount+1);
3327*0Sstevel@tonic-gate }
3328*0Sstevel@tonic-gate }
3329*0Sstevel@tonic-gate }
3330*0Sstevel@tonic-gate }
3331*0Sstevel@tonic-gate return o;
3332*0Sstevel@tonic-gate }
3333*0Sstevel@tonic-gate if (!right)
3334*0Sstevel@tonic-gate right = newOP(OP_UNDEF, 0);
3335*0Sstevel@tonic-gate if (right->op_type == OP_READLINE) {
3336*0Sstevel@tonic-gate right->op_flags |= OPf_STACKED;
3337*0Sstevel@tonic-gate return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3338*0Sstevel@tonic-gate }
3339*0Sstevel@tonic-gate else {
3340*0Sstevel@tonic-gate PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3341*0Sstevel@tonic-gate o = newBINOP(OP_SASSIGN, flags,
3342*0Sstevel@tonic-gate scalar(right), mod(scalar(left), OP_SASSIGN) );
3343*0Sstevel@tonic-gate if (PL_eval_start)
3344*0Sstevel@tonic-gate PL_eval_start = 0;
3345*0Sstevel@tonic-gate else {
3346*0Sstevel@tonic-gate op_free(o);
3347*0Sstevel@tonic-gate return Nullop;
3348*0Sstevel@tonic-gate }
3349*0Sstevel@tonic-gate }
3350*0Sstevel@tonic-gate return o;
3351*0Sstevel@tonic-gate }
3352*0Sstevel@tonic-gate
3353*0Sstevel@tonic-gate OP *
Perl_newSTATEOP(pTHX_ I32 flags,char * label,OP * o)3354*0Sstevel@tonic-gate Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3355*0Sstevel@tonic-gate {
3356*0Sstevel@tonic-gate U32 seq = intro_my();
3357*0Sstevel@tonic-gate register COP *cop;
3358*0Sstevel@tonic-gate
3359*0Sstevel@tonic-gate NewOp(1101, cop, 1, COP);
3360*0Sstevel@tonic-gate if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3361*0Sstevel@tonic-gate cop->op_type = OP_DBSTATE;
3362*0Sstevel@tonic-gate cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3363*0Sstevel@tonic-gate }
3364*0Sstevel@tonic-gate else {
3365*0Sstevel@tonic-gate cop->op_type = OP_NEXTSTATE;
3366*0Sstevel@tonic-gate cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3367*0Sstevel@tonic-gate }
3368*0Sstevel@tonic-gate cop->op_flags = (U8)flags;
3369*0Sstevel@tonic-gate cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3370*0Sstevel@tonic-gate #ifdef NATIVE_HINTS
3371*0Sstevel@tonic-gate cop->op_private |= NATIVE_HINTS;
3372*0Sstevel@tonic-gate #endif
3373*0Sstevel@tonic-gate PL_compiling.op_private = cop->op_private;
3374*0Sstevel@tonic-gate cop->op_next = (OP*)cop;
3375*0Sstevel@tonic-gate
3376*0Sstevel@tonic-gate if (label) {
3377*0Sstevel@tonic-gate cop->cop_label = label;
3378*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE;
3379*0Sstevel@tonic-gate }
3380*0Sstevel@tonic-gate cop->cop_seq = seq;
3381*0Sstevel@tonic-gate cop->cop_arybase = PL_curcop->cop_arybase;
3382*0Sstevel@tonic-gate if (specialWARN(PL_curcop->cop_warnings))
3383*0Sstevel@tonic-gate cop->cop_warnings = PL_curcop->cop_warnings ;
3384*0Sstevel@tonic-gate else
3385*0Sstevel@tonic-gate cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3386*0Sstevel@tonic-gate if (specialCopIO(PL_curcop->cop_io))
3387*0Sstevel@tonic-gate cop->cop_io = PL_curcop->cop_io;
3388*0Sstevel@tonic-gate else
3389*0Sstevel@tonic-gate cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3390*0Sstevel@tonic-gate
3391*0Sstevel@tonic-gate
3392*0Sstevel@tonic-gate if (PL_copline == NOLINE)
3393*0Sstevel@tonic-gate CopLINE_set(cop, CopLINE(PL_curcop));
3394*0Sstevel@tonic-gate else {
3395*0Sstevel@tonic-gate CopLINE_set(cop, PL_copline);
3396*0Sstevel@tonic-gate PL_copline = NOLINE;
3397*0Sstevel@tonic-gate }
3398*0Sstevel@tonic-gate #ifdef USE_ITHREADS
3399*0Sstevel@tonic-gate CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3400*0Sstevel@tonic-gate #else
3401*0Sstevel@tonic-gate CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3402*0Sstevel@tonic-gate #endif
3403*0Sstevel@tonic-gate CopSTASH_set(cop, PL_curstash);
3404*0Sstevel@tonic-gate
3405*0Sstevel@tonic-gate if (PERLDB_LINE && PL_curstash != PL_debstash) {
3406*0Sstevel@tonic-gate SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3407*0Sstevel@tonic-gate if (svp && *svp != &PL_sv_undef ) {
3408*0Sstevel@tonic-gate (void)SvIOK_on(*svp);
3409*0Sstevel@tonic-gate SvIVX(*svp) = PTR2IV(cop);
3410*0Sstevel@tonic-gate }
3411*0Sstevel@tonic-gate }
3412*0Sstevel@tonic-gate
3413*0Sstevel@tonic-gate return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3414*0Sstevel@tonic-gate }
3415*0Sstevel@tonic-gate
3416*0Sstevel@tonic-gate
3417*0Sstevel@tonic-gate OP *
Perl_newLOGOP(pTHX_ I32 type,I32 flags,OP * first,OP * other)3418*0Sstevel@tonic-gate Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3419*0Sstevel@tonic-gate {
3420*0Sstevel@tonic-gate return new_logop(type, flags, &first, &other);
3421*0Sstevel@tonic-gate }
3422*0Sstevel@tonic-gate
3423*0Sstevel@tonic-gate STATIC OP *
S_new_logop(pTHX_ I32 type,I32 flags,OP ** firstp,OP ** otherp)3424*0Sstevel@tonic-gate S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3425*0Sstevel@tonic-gate {
3426*0Sstevel@tonic-gate LOGOP *logop;
3427*0Sstevel@tonic-gate OP *o;
3428*0Sstevel@tonic-gate OP *first = *firstp;
3429*0Sstevel@tonic-gate OP *other = *otherp;
3430*0Sstevel@tonic-gate
3431*0Sstevel@tonic-gate if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3432*0Sstevel@tonic-gate return newBINOP(type, flags, scalar(first), scalar(other));
3433*0Sstevel@tonic-gate
3434*0Sstevel@tonic-gate scalarboolean(first);
3435*0Sstevel@tonic-gate /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3436*0Sstevel@tonic-gate if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3437*0Sstevel@tonic-gate if (type == OP_AND || type == OP_OR) {
3438*0Sstevel@tonic-gate if (type == OP_AND)
3439*0Sstevel@tonic-gate type = OP_OR;
3440*0Sstevel@tonic-gate else
3441*0Sstevel@tonic-gate type = OP_AND;
3442*0Sstevel@tonic-gate o = first;
3443*0Sstevel@tonic-gate first = *firstp = cUNOPo->op_first;
3444*0Sstevel@tonic-gate if (o->op_next)
3445*0Sstevel@tonic-gate first->op_next = o->op_next;
3446*0Sstevel@tonic-gate cUNOPo->op_first = Nullop;
3447*0Sstevel@tonic-gate op_free(o);
3448*0Sstevel@tonic-gate }
3449*0Sstevel@tonic-gate }
3450*0Sstevel@tonic-gate if (first->op_type == OP_CONST) {
3451*0Sstevel@tonic-gate if (first->op_private & OPpCONST_STRICT)
3452*0Sstevel@tonic-gate no_bareword_allowed(first);
3453*0Sstevel@tonic-gate else if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3454*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3455*0Sstevel@tonic-gate if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3456*0Sstevel@tonic-gate op_free(first);
3457*0Sstevel@tonic-gate *firstp = Nullop;
3458*0Sstevel@tonic-gate if (other->op_type == OP_CONST)
3459*0Sstevel@tonic-gate other->op_private |= OPpCONST_SHORTCIRCUIT;
3460*0Sstevel@tonic-gate return other;
3461*0Sstevel@tonic-gate }
3462*0Sstevel@tonic-gate else {
3463*0Sstevel@tonic-gate op_free(other);
3464*0Sstevel@tonic-gate *otherp = Nullop;
3465*0Sstevel@tonic-gate if (first->op_type == OP_CONST)
3466*0Sstevel@tonic-gate first->op_private |= OPpCONST_SHORTCIRCUIT;
3467*0Sstevel@tonic-gate return first;
3468*0Sstevel@tonic-gate }
3469*0Sstevel@tonic-gate }
3470*0Sstevel@tonic-gate else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3471*0Sstevel@tonic-gate OP *k1 = ((UNOP*)first)->op_first;
3472*0Sstevel@tonic-gate OP *k2 = k1->op_sibling;
3473*0Sstevel@tonic-gate OPCODE warnop = 0;
3474*0Sstevel@tonic-gate switch (first->op_type)
3475*0Sstevel@tonic-gate {
3476*0Sstevel@tonic-gate case OP_NULL:
3477*0Sstevel@tonic-gate if (k2 && k2->op_type == OP_READLINE
3478*0Sstevel@tonic-gate && (k2->op_flags & OPf_STACKED)
3479*0Sstevel@tonic-gate && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3480*0Sstevel@tonic-gate {
3481*0Sstevel@tonic-gate warnop = k2->op_type;
3482*0Sstevel@tonic-gate }
3483*0Sstevel@tonic-gate break;
3484*0Sstevel@tonic-gate
3485*0Sstevel@tonic-gate case OP_SASSIGN:
3486*0Sstevel@tonic-gate if (k1->op_type == OP_READDIR
3487*0Sstevel@tonic-gate || k1->op_type == OP_GLOB
3488*0Sstevel@tonic-gate || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3489*0Sstevel@tonic-gate || k1->op_type == OP_EACH)
3490*0Sstevel@tonic-gate {
3491*0Sstevel@tonic-gate warnop = ((k1->op_type == OP_NULL)
3492*0Sstevel@tonic-gate ? (OPCODE)k1->op_targ : k1->op_type);
3493*0Sstevel@tonic-gate }
3494*0Sstevel@tonic-gate break;
3495*0Sstevel@tonic-gate }
3496*0Sstevel@tonic-gate if (warnop) {
3497*0Sstevel@tonic-gate line_t oldline = CopLINE(PL_curcop);
3498*0Sstevel@tonic-gate CopLINE_set(PL_curcop, PL_copline);
3499*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_MISC),
3500*0Sstevel@tonic-gate "Value of %s%s can be \"0\"; test with defined()",
3501*0Sstevel@tonic-gate PL_op_desc[warnop],
3502*0Sstevel@tonic-gate ((warnop == OP_READLINE || warnop == OP_GLOB)
3503*0Sstevel@tonic-gate ? " construct" : "() operator"));
3504*0Sstevel@tonic-gate CopLINE_set(PL_curcop, oldline);
3505*0Sstevel@tonic-gate }
3506*0Sstevel@tonic-gate }
3507*0Sstevel@tonic-gate
3508*0Sstevel@tonic-gate if (!other)
3509*0Sstevel@tonic-gate return first;
3510*0Sstevel@tonic-gate
3511*0Sstevel@tonic-gate if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3512*0Sstevel@tonic-gate other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3513*0Sstevel@tonic-gate
3514*0Sstevel@tonic-gate NewOp(1101, logop, 1, LOGOP);
3515*0Sstevel@tonic-gate
3516*0Sstevel@tonic-gate logop->op_type = (OPCODE)type;
3517*0Sstevel@tonic-gate logop->op_ppaddr = PL_ppaddr[type];
3518*0Sstevel@tonic-gate logop->op_first = first;
3519*0Sstevel@tonic-gate logop->op_flags = flags | OPf_KIDS;
3520*0Sstevel@tonic-gate logop->op_other = LINKLIST(other);
3521*0Sstevel@tonic-gate logop->op_private = (U8)(1 | (flags >> 8));
3522*0Sstevel@tonic-gate
3523*0Sstevel@tonic-gate /* establish postfix order */
3524*0Sstevel@tonic-gate logop->op_next = LINKLIST(first);
3525*0Sstevel@tonic-gate first->op_next = (OP*)logop;
3526*0Sstevel@tonic-gate first->op_sibling = other;
3527*0Sstevel@tonic-gate
3528*0Sstevel@tonic-gate CHECKOP(type,logop);
3529*0Sstevel@tonic-gate
3530*0Sstevel@tonic-gate o = newUNOP(OP_NULL, 0, (OP*)logop);
3531*0Sstevel@tonic-gate other->op_next = o;
3532*0Sstevel@tonic-gate
3533*0Sstevel@tonic-gate return o;
3534*0Sstevel@tonic-gate }
3535*0Sstevel@tonic-gate
3536*0Sstevel@tonic-gate OP *
Perl_newCONDOP(pTHX_ I32 flags,OP * first,OP * trueop,OP * falseop)3537*0Sstevel@tonic-gate Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3538*0Sstevel@tonic-gate {
3539*0Sstevel@tonic-gate LOGOP *logop;
3540*0Sstevel@tonic-gate OP *start;
3541*0Sstevel@tonic-gate OP *o;
3542*0Sstevel@tonic-gate
3543*0Sstevel@tonic-gate if (!falseop)
3544*0Sstevel@tonic-gate return newLOGOP(OP_AND, 0, first, trueop);
3545*0Sstevel@tonic-gate if (!trueop)
3546*0Sstevel@tonic-gate return newLOGOP(OP_OR, 0, first, falseop);
3547*0Sstevel@tonic-gate
3548*0Sstevel@tonic-gate scalarboolean(first);
3549*0Sstevel@tonic-gate if (first->op_type == OP_CONST) {
3550*0Sstevel@tonic-gate if (first->op_private & OPpCONST_BARE &&
3551*0Sstevel@tonic-gate first->op_private & OPpCONST_STRICT) {
3552*0Sstevel@tonic-gate no_bareword_allowed(first);
3553*0Sstevel@tonic-gate }
3554*0Sstevel@tonic-gate if (SvTRUE(((SVOP*)first)->op_sv)) {
3555*0Sstevel@tonic-gate op_free(first);
3556*0Sstevel@tonic-gate op_free(falseop);
3557*0Sstevel@tonic-gate return trueop;
3558*0Sstevel@tonic-gate }
3559*0Sstevel@tonic-gate else {
3560*0Sstevel@tonic-gate op_free(first);
3561*0Sstevel@tonic-gate op_free(trueop);
3562*0Sstevel@tonic-gate return falseop;
3563*0Sstevel@tonic-gate }
3564*0Sstevel@tonic-gate }
3565*0Sstevel@tonic-gate NewOp(1101, logop, 1, LOGOP);
3566*0Sstevel@tonic-gate logop->op_type = OP_COND_EXPR;
3567*0Sstevel@tonic-gate logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3568*0Sstevel@tonic-gate logop->op_first = first;
3569*0Sstevel@tonic-gate logop->op_flags = flags | OPf_KIDS;
3570*0Sstevel@tonic-gate logop->op_private = (U8)(1 | (flags >> 8));
3571*0Sstevel@tonic-gate logop->op_other = LINKLIST(trueop);
3572*0Sstevel@tonic-gate logop->op_next = LINKLIST(falseop);
3573*0Sstevel@tonic-gate
3574*0Sstevel@tonic-gate CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3575*0Sstevel@tonic-gate logop);
3576*0Sstevel@tonic-gate
3577*0Sstevel@tonic-gate /* establish postfix order */
3578*0Sstevel@tonic-gate start = LINKLIST(first);
3579*0Sstevel@tonic-gate first->op_next = (OP*)logop;
3580*0Sstevel@tonic-gate
3581*0Sstevel@tonic-gate first->op_sibling = trueop;
3582*0Sstevel@tonic-gate trueop->op_sibling = falseop;
3583*0Sstevel@tonic-gate o = newUNOP(OP_NULL, 0, (OP*)logop);
3584*0Sstevel@tonic-gate
3585*0Sstevel@tonic-gate trueop->op_next = falseop->op_next = o;
3586*0Sstevel@tonic-gate
3587*0Sstevel@tonic-gate o->op_next = start;
3588*0Sstevel@tonic-gate return o;
3589*0Sstevel@tonic-gate }
3590*0Sstevel@tonic-gate
3591*0Sstevel@tonic-gate OP *
Perl_newRANGE(pTHX_ I32 flags,OP * left,OP * right)3592*0Sstevel@tonic-gate Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3593*0Sstevel@tonic-gate {
3594*0Sstevel@tonic-gate LOGOP *range;
3595*0Sstevel@tonic-gate OP *flip;
3596*0Sstevel@tonic-gate OP *flop;
3597*0Sstevel@tonic-gate OP *leftstart;
3598*0Sstevel@tonic-gate OP *o;
3599*0Sstevel@tonic-gate
3600*0Sstevel@tonic-gate NewOp(1101, range, 1, LOGOP);
3601*0Sstevel@tonic-gate
3602*0Sstevel@tonic-gate range->op_type = OP_RANGE;
3603*0Sstevel@tonic-gate range->op_ppaddr = PL_ppaddr[OP_RANGE];
3604*0Sstevel@tonic-gate range->op_first = left;
3605*0Sstevel@tonic-gate range->op_flags = OPf_KIDS;
3606*0Sstevel@tonic-gate leftstart = LINKLIST(left);
3607*0Sstevel@tonic-gate range->op_other = LINKLIST(right);
3608*0Sstevel@tonic-gate range->op_private = (U8)(1 | (flags >> 8));
3609*0Sstevel@tonic-gate
3610*0Sstevel@tonic-gate left->op_sibling = right;
3611*0Sstevel@tonic-gate
3612*0Sstevel@tonic-gate range->op_next = (OP*)range;
3613*0Sstevel@tonic-gate flip = newUNOP(OP_FLIP, flags, (OP*)range);
3614*0Sstevel@tonic-gate flop = newUNOP(OP_FLOP, 0, flip);
3615*0Sstevel@tonic-gate o = newUNOP(OP_NULL, 0, flop);
3616*0Sstevel@tonic-gate linklist(flop);
3617*0Sstevel@tonic-gate range->op_next = leftstart;
3618*0Sstevel@tonic-gate
3619*0Sstevel@tonic-gate left->op_next = flip;
3620*0Sstevel@tonic-gate right->op_next = flop;
3621*0Sstevel@tonic-gate
3622*0Sstevel@tonic-gate range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3623*0Sstevel@tonic-gate sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3624*0Sstevel@tonic-gate flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3625*0Sstevel@tonic-gate sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3626*0Sstevel@tonic-gate
3627*0Sstevel@tonic-gate flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3628*0Sstevel@tonic-gate flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3629*0Sstevel@tonic-gate
3630*0Sstevel@tonic-gate flip->op_next = o;
3631*0Sstevel@tonic-gate if (!flip->op_private || !flop->op_private)
3632*0Sstevel@tonic-gate linklist(o); /* blow off optimizer unless constant */
3633*0Sstevel@tonic-gate
3634*0Sstevel@tonic-gate return o;
3635*0Sstevel@tonic-gate }
3636*0Sstevel@tonic-gate
3637*0Sstevel@tonic-gate OP *
Perl_newLOOPOP(pTHX_ I32 flags,I32 debuggable,OP * expr,OP * block)3638*0Sstevel@tonic-gate Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3639*0Sstevel@tonic-gate {
3640*0Sstevel@tonic-gate OP* listop;
3641*0Sstevel@tonic-gate OP* o;
3642*0Sstevel@tonic-gate int once = block && block->op_flags & OPf_SPECIAL &&
3643*0Sstevel@tonic-gate (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3644*0Sstevel@tonic-gate
3645*0Sstevel@tonic-gate if (expr) {
3646*0Sstevel@tonic-gate if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3647*0Sstevel@tonic-gate return block; /* do {} while 0 does once */
3648*0Sstevel@tonic-gate if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3649*0Sstevel@tonic-gate || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3650*0Sstevel@tonic-gate expr = newUNOP(OP_DEFINED, 0,
3651*0Sstevel@tonic-gate newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3652*0Sstevel@tonic-gate } else if (expr->op_flags & OPf_KIDS) {
3653*0Sstevel@tonic-gate OP *k1 = ((UNOP*)expr)->op_first;
3654*0Sstevel@tonic-gate OP *k2 = (k1) ? k1->op_sibling : NULL;
3655*0Sstevel@tonic-gate switch (expr->op_type) {
3656*0Sstevel@tonic-gate case OP_NULL:
3657*0Sstevel@tonic-gate if (k2 && k2->op_type == OP_READLINE
3658*0Sstevel@tonic-gate && (k2->op_flags & OPf_STACKED)
3659*0Sstevel@tonic-gate && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3660*0Sstevel@tonic-gate expr = newUNOP(OP_DEFINED, 0, expr);
3661*0Sstevel@tonic-gate break;
3662*0Sstevel@tonic-gate
3663*0Sstevel@tonic-gate case OP_SASSIGN:
3664*0Sstevel@tonic-gate if (k1->op_type == OP_READDIR
3665*0Sstevel@tonic-gate || k1->op_type == OP_GLOB
3666*0Sstevel@tonic-gate || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3667*0Sstevel@tonic-gate || k1->op_type == OP_EACH)
3668*0Sstevel@tonic-gate expr = newUNOP(OP_DEFINED, 0, expr);
3669*0Sstevel@tonic-gate break;
3670*0Sstevel@tonic-gate }
3671*0Sstevel@tonic-gate }
3672*0Sstevel@tonic-gate }
3673*0Sstevel@tonic-gate
3674*0Sstevel@tonic-gate /* if block is null, the next append_elem() would put UNSTACK, a scalar
3675*0Sstevel@tonic-gate * op, in listop. This is wrong. [perl #27024] */
3676*0Sstevel@tonic-gate if (!block)
3677*0Sstevel@tonic-gate block = newOP(OP_NULL, 0);
3678*0Sstevel@tonic-gate listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3679*0Sstevel@tonic-gate o = new_logop(OP_AND, 0, &expr, &listop);
3680*0Sstevel@tonic-gate
3681*0Sstevel@tonic-gate if (listop)
3682*0Sstevel@tonic-gate ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3683*0Sstevel@tonic-gate
3684*0Sstevel@tonic-gate if (once && o != listop)
3685*0Sstevel@tonic-gate o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3686*0Sstevel@tonic-gate
3687*0Sstevel@tonic-gate if (o == listop)
3688*0Sstevel@tonic-gate o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3689*0Sstevel@tonic-gate
3690*0Sstevel@tonic-gate o->op_flags |= flags;
3691*0Sstevel@tonic-gate o = scope(o);
3692*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3693*0Sstevel@tonic-gate return o;
3694*0Sstevel@tonic-gate }
3695*0Sstevel@tonic-gate
3696*0Sstevel@tonic-gate OP *
Perl_newWHILEOP(pTHX_ I32 flags,I32 debuggable,LOOP * loop,I32 whileline,OP * expr,OP * block,OP * cont)3697*0Sstevel@tonic-gate Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3698*0Sstevel@tonic-gate {
3699*0Sstevel@tonic-gate OP *redo;
3700*0Sstevel@tonic-gate OP *next = 0;
3701*0Sstevel@tonic-gate OP *listop;
3702*0Sstevel@tonic-gate OP *o;
3703*0Sstevel@tonic-gate U8 loopflags = 0;
3704*0Sstevel@tonic-gate
3705*0Sstevel@tonic-gate if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3706*0Sstevel@tonic-gate || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3707*0Sstevel@tonic-gate expr = newUNOP(OP_DEFINED, 0,
3708*0Sstevel@tonic-gate newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3709*0Sstevel@tonic-gate } else if (expr && (expr->op_flags & OPf_KIDS)) {
3710*0Sstevel@tonic-gate OP *k1 = ((UNOP*)expr)->op_first;
3711*0Sstevel@tonic-gate OP *k2 = (k1) ? k1->op_sibling : NULL;
3712*0Sstevel@tonic-gate switch (expr->op_type) {
3713*0Sstevel@tonic-gate case OP_NULL:
3714*0Sstevel@tonic-gate if (k2 && k2->op_type == OP_READLINE
3715*0Sstevel@tonic-gate && (k2->op_flags & OPf_STACKED)
3716*0Sstevel@tonic-gate && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3717*0Sstevel@tonic-gate expr = newUNOP(OP_DEFINED, 0, expr);
3718*0Sstevel@tonic-gate break;
3719*0Sstevel@tonic-gate
3720*0Sstevel@tonic-gate case OP_SASSIGN:
3721*0Sstevel@tonic-gate if (k1->op_type == OP_READDIR
3722*0Sstevel@tonic-gate || k1->op_type == OP_GLOB
3723*0Sstevel@tonic-gate || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3724*0Sstevel@tonic-gate || k1->op_type == OP_EACH)
3725*0Sstevel@tonic-gate expr = newUNOP(OP_DEFINED, 0, expr);
3726*0Sstevel@tonic-gate break;
3727*0Sstevel@tonic-gate }
3728*0Sstevel@tonic-gate }
3729*0Sstevel@tonic-gate
3730*0Sstevel@tonic-gate if (!block)
3731*0Sstevel@tonic-gate block = newOP(OP_NULL, 0);
3732*0Sstevel@tonic-gate else if (cont) {
3733*0Sstevel@tonic-gate block = scope(block);
3734*0Sstevel@tonic-gate }
3735*0Sstevel@tonic-gate
3736*0Sstevel@tonic-gate if (cont) {
3737*0Sstevel@tonic-gate next = LINKLIST(cont);
3738*0Sstevel@tonic-gate }
3739*0Sstevel@tonic-gate if (expr) {
3740*0Sstevel@tonic-gate OP *unstack = newOP(OP_UNSTACK, 0);
3741*0Sstevel@tonic-gate if (!next)
3742*0Sstevel@tonic-gate next = unstack;
3743*0Sstevel@tonic-gate cont = append_elem(OP_LINESEQ, cont, unstack);
3744*0Sstevel@tonic-gate }
3745*0Sstevel@tonic-gate
3746*0Sstevel@tonic-gate listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3747*0Sstevel@tonic-gate redo = LINKLIST(listop);
3748*0Sstevel@tonic-gate
3749*0Sstevel@tonic-gate if (expr) {
3750*0Sstevel@tonic-gate PL_copline = (line_t)whileline;
3751*0Sstevel@tonic-gate scalar(listop);
3752*0Sstevel@tonic-gate o = new_logop(OP_AND, 0, &expr, &listop);
3753*0Sstevel@tonic-gate if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3754*0Sstevel@tonic-gate op_free(expr); /* oops, it's a while (0) */
3755*0Sstevel@tonic-gate op_free((OP*)loop);
3756*0Sstevel@tonic-gate return Nullop; /* listop already freed by new_logop */
3757*0Sstevel@tonic-gate }
3758*0Sstevel@tonic-gate if (listop)
3759*0Sstevel@tonic-gate ((LISTOP*)listop)->op_last->op_next =
3760*0Sstevel@tonic-gate (o == listop ? redo : LINKLIST(o));
3761*0Sstevel@tonic-gate }
3762*0Sstevel@tonic-gate else
3763*0Sstevel@tonic-gate o = listop;
3764*0Sstevel@tonic-gate
3765*0Sstevel@tonic-gate if (!loop) {
3766*0Sstevel@tonic-gate NewOp(1101,loop,1,LOOP);
3767*0Sstevel@tonic-gate loop->op_type = OP_ENTERLOOP;
3768*0Sstevel@tonic-gate loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3769*0Sstevel@tonic-gate loop->op_private = 0;
3770*0Sstevel@tonic-gate loop->op_next = (OP*)loop;
3771*0Sstevel@tonic-gate }
3772*0Sstevel@tonic-gate
3773*0Sstevel@tonic-gate o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3774*0Sstevel@tonic-gate
3775*0Sstevel@tonic-gate loop->op_redoop = redo;
3776*0Sstevel@tonic-gate loop->op_lastop = o;
3777*0Sstevel@tonic-gate o->op_private |= loopflags;
3778*0Sstevel@tonic-gate
3779*0Sstevel@tonic-gate if (next)
3780*0Sstevel@tonic-gate loop->op_nextop = next;
3781*0Sstevel@tonic-gate else
3782*0Sstevel@tonic-gate loop->op_nextop = o;
3783*0Sstevel@tonic-gate
3784*0Sstevel@tonic-gate o->op_flags |= flags;
3785*0Sstevel@tonic-gate o->op_private |= (flags >> 8);
3786*0Sstevel@tonic-gate return o;
3787*0Sstevel@tonic-gate }
3788*0Sstevel@tonic-gate
3789*0Sstevel@tonic-gate OP *
Perl_newFOROP(pTHX_ I32 flags,char * label,line_t forline,OP * sv,OP * expr,OP * block,OP * cont)3790*0Sstevel@tonic-gate Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3791*0Sstevel@tonic-gate {
3792*0Sstevel@tonic-gate LOOP *loop;
3793*0Sstevel@tonic-gate OP *wop;
3794*0Sstevel@tonic-gate PADOFFSET padoff = 0;
3795*0Sstevel@tonic-gate I32 iterflags = 0;
3796*0Sstevel@tonic-gate I32 iterpflags = 0;
3797*0Sstevel@tonic-gate
3798*0Sstevel@tonic-gate if (sv) {
3799*0Sstevel@tonic-gate if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3800*0Sstevel@tonic-gate iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3801*0Sstevel@tonic-gate sv->op_type = OP_RV2GV;
3802*0Sstevel@tonic-gate sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3803*0Sstevel@tonic-gate }
3804*0Sstevel@tonic-gate else if (sv->op_type == OP_PADSV) { /* private variable */
3805*0Sstevel@tonic-gate iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3806*0Sstevel@tonic-gate padoff = sv->op_targ;
3807*0Sstevel@tonic-gate sv->op_targ = 0;
3808*0Sstevel@tonic-gate op_free(sv);
3809*0Sstevel@tonic-gate sv = Nullop;
3810*0Sstevel@tonic-gate }
3811*0Sstevel@tonic-gate else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3812*0Sstevel@tonic-gate padoff = sv->op_targ;
3813*0Sstevel@tonic-gate sv->op_targ = 0;
3814*0Sstevel@tonic-gate iterflags |= OPf_SPECIAL;
3815*0Sstevel@tonic-gate op_free(sv);
3816*0Sstevel@tonic-gate sv = Nullop;
3817*0Sstevel@tonic-gate }
3818*0Sstevel@tonic-gate else
3819*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3820*0Sstevel@tonic-gate }
3821*0Sstevel@tonic-gate else {
3822*0Sstevel@tonic-gate #ifdef USE_5005THREADS
3823*0Sstevel@tonic-gate padoff = find_threadsv("_");
3824*0Sstevel@tonic-gate iterflags |= OPf_SPECIAL;
3825*0Sstevel@tonic-gate #else
3826*0Sstevel@tonic-gate sv = newGVOP(OP_GV, 0, PL_defgv);
3827*0Sstevel@tonic-gate #endif
3828*0Sstevel@tonic-gate }
3829*0Sstevel@tonic-gate if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3830*0Sstevel@tonic-gate expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3831*0Sstevel@tonic-gate iterflags |= OPf_STACKED;
3832*0Sstevel@tonic-gate }
3833*0Sstevel@tonic-gate else if (expr->op_type == OP_NULL &&
3834*0Sstevel@tonic-gate (expr->op_flags & OPf_KIDS) &&
3835*0Sstevel@tonic-gate ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3836*0Sstevel@tonic-gate {
3837*0Sstevel@tonic-gate /* Basically turn for($x..$y) into the same as for($x,$y), but we
3838*0Sstevel@tonic-gate * set the STACKED flag to indicate that these values are to be
3839*0Sstevel@tonic-gate * treated as min/max values by 'pp_iterinit'.
3840*0Sstevel@tonic-gate */
3841*0Sstevel@tonic-gate UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3842*0Sstevel@tonic-gate LOGOP* range = (LOGOP*) flip->op_first;
3843*0Sstevel@tonic-gate OP* left = range->op_first;
3844*0Sstevel@tonic-gate OP* right = left->op_sibling;
3845*0Sstevel@tonic-gate LISTOP* listop;
3846*0Sstevel@tonic-gate
3847*0Sstevel@tonic-gate range->op_flags &= ~OPf_KIDS;
3848*0Sstevel@tonic-gate range->op_first = Nullop;
3849*0Sstevel@tonic-gate
3850*0Sstevel@tonic-gate listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3851*0Sstevel@tonic-gate listop->op_first->op_next = range->op_next;
3852*0Sstevel@tonic-gate left->op_next = range->op_other;
3853*0Sstevel@tonic-gate right->op_next = (OP*)listop;
3854*0Sstevel@tonic-gate listop->op_next = listop->op_first;
3855*0Sstevel@tonic-gate
3856*0Sstevel@tonic-gate op_free(expr);
3857*0Sstevel@tonic-gate expr = (OP*)(listop);
3858*0Sstevel@tonic-gate op_null(expr);
3859*0Sstevel@tonic-gate iterflags |= OPf_STACKED;
3860*0Sstevel@tonic-gate }
3861*0Sstevel@tonic-gate else {
3862*0Sstevel@tonic-gate expr = mod(force_list(expr), OP_GREPSTART);
3863*0Sstevel@tonic-gate }
3864*0Sstevel@tonic-gate
3865*0Sstevel@tonic-gate
3866*0Sstevel@tonic-gate loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3867*0Sstevel@tonic-gate append_elem(OP_LIST, expr, scalar(sv))));
3868*0Sstevel@tonic-gate assert(!loop->op_next);
3869*0Sstevel@tonic-gate /* for my $x () sets OPpLVAL_INTRO;
3870*0Sstevel@tonic-gate * for our $x () sets OPpOUR_INTRO; both only used by Deparse.pm */
3871*0Sstevel@tonic-gate loop->op_private = (U8)iterpflags;
3872*0Sstevel@tonic-gate #ifdef PL_OP_SLAB_ALLOC
3873*0Sstevel@tonic-gate {
3874*0Sstevel@tonic-gate LOOP *tmp;
3875*0Sstevel@tonic-gate NewOp(1234,tmp,1,LOOP);
3876*0Sstevel@tonic-gate Copy(loop,tmp,1,LOOP);
3877*0Sstevel@tonic-gate FreeOp(loop);
3878*0Sstevel@tonic-gate loop = tmp;
3879*0Sstevel@tonic-gate }
3880*0Sstevel@tonic-gate #else
3881*0Sstevel@tonic-gate Renew(loop, 1, LOOP);
3882*0Sstevel@tonic-gate #endif
3883*0Sstevel@tonic-gate loop->op_targ = padoff;
3884*0Sstevel@tonic-gate wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3885*0Sstevel@tonic-gate PL_copline = forline;
3886*0Sstevel@tonic-gate return newSTATEOP(0, label, wop);
3887*0Sstevel@tonic-gate }
3888*0Sstevel@tonic-gate
3889*0Sstevel@tonic-gate OP*
Perl_newLOOPEX(pTHX_ I32 type,OP * label)3890*0Sstevel@tonic-gate Perl_newLOOPEX(pTHX_ I32 type, OP *label)
3891*0Sstevel@tonic-gate {
3892*0Sstevel@tonic-gate OP *o;
3893*0Sstevel@tonic-gate STRLEN n_a;
3894*0Sstevel@tonic-gate
3895*0Sstevel@tonic-gate if (type != OP_GOTO || label->op_type == OP_CONST) {
3896*0Sstevel@tonic-gate /* "last()" means "last" */
3897*0Sstevel@tonic-gate if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3898*0Sstevel@tonic-gate o = newOP(type, OPf_SPECIAL);
3899*0Sstevel@tonic-gate else {
3900*0Sstevel@tonic-gate o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3901*0Sstevel@tonic-gate ? SvPVx(((SVOP*)label)->op_sv, n_a)
3902*0Sstevel@tonic-gate : ""));
3903*0Sstevel@tonic-gate }
3904*0Sstevel@tonic-gate op_free(label);
3905*0Sstevel@tonic-gate }
3906*0Sstevel@tonic-gate else {
3907*0Sstevel@tonic-gate /* Check whether it's going to be a goto &function */
3908*0Sstevel@tonic-gate if (label->op_type == OP_ENTERSUB
3909*0Sstevel@tonic-gate && !(label->op_flags & OPf_STACKED))
3910*0Sstevel@tonic-gate label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3911*0Sstevel@tonic-gate o = newUNOP(type, OPf_STACKED, label);
3912*0Sstevel@tonic-gate }
3913*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE;
3914*0Sstevel@tonic-gate return o;
3915*0Sstevel@tonic-gate }
3916*0Sstevel@tonic-gate
3917*0Sstevel@tonic-gate /*
3918*0Sstevel@tonic-gate =for apidoc cv_undef
3919*0Sstevel@tonic-gate
3920*0Sstevel@tonic-gate Clear out all the active components of a CV. This can happen either
3921*0Sstevel@tonic-gate by an explicit C<undef &foo>, or by the reference count going to zero.
3922*0Sstevel@tonic-gate In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
3923*0Sstevel@tonic-gate children can still follow the full lexical scope chain.
3924*0Sstevel@tonic-gate
3925*0Sstevel@tonic-gate =cut
3926*0Sstevel@tonic-gate */
3927*0Sstevel@tonic-gate
3928*0Sstevel@tonic-gate void
Perl_cv_undef(pTHX_ CV * cv)3929*0Sstevel@tonic-gate Perl_cv_undef(pTHX_ CV *cv)
3930*0Sstevel@tonic-gate {
3931*0Sstevel@tonic-gate #ifdef USE_5005THREADS
3932*0Sstevel@tonic-gate if (CvMUTEXP(cv)) {
3933*0Sstevel@tonic-gate MUTEX_DESTROY(CvMUTEXP(cv));
3934*0Sstevel@tonic-gate Safefree(CvMUTEXP(cv));
3935*0Sstevel@tonic-gate CvMUTEXP(cv) = 0;
3936*0Sstevel@tonic-gate }
3937*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
3938*0Sstevel@tonic-gate
3939*0Sstevel@tonic-gate #ifdef USE_ITHREADS
3940*0Sstevel@tonic-gate if (CvFILE(cv) && !CvXSUB(cv)) {
3941*0Sstevel@tonic-gate /* for XSUBs CvFILE point directly to static memory; __FILE__ */
3942*0Sstevel@tonic-gate Safefree(CvFILE(cv));
3943*0Sstevel@tonic-gate }
3944*0Sstevel@tonic-gate CvFILE(cv) = 0;
3945*0Sstevel@tonic-gate #endif
3946*0Sstevel@tonic-gate
3947*0Sstevel@tonic-gate if (!CvXSUB(cv) && CvROOT(cv)) {
3948*0Sstevel@tonic-gate #ifdef USE_5005THREADS
3949*0Sstevel@tonic-gate if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
3950*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can't undef active subroutine");
3951*0Sstevel@tonic-gate #else
3952*0Sstevel@tonic-gate if (CvDEPTH(cv))
3953*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can't undef active subroutine");
3954*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
3955*0Sstevel@tonic-gate ENTER;
3956*0Sstevel@tonic-gate
3957*0Sstevel@tonic-gate PAD_SAVE_SETNULLPAD();
3958*0Sstevel@tonic-gate
3959*0Sstevel@tonic-gate op_free(CvROOT(cv));
3960*0Sstevel@tonic-gate CvROOT(cv) = Nullop;
3961*0Sstevel@tonic-gate LEAVE;
3962*0Sstevel@tonic-gate }
3963*0Sstevel@tonic-gate SvPOK_off((SV*)cv); /* forget prototype */
3964*0Sstevel@tonic-gate CvGV(cv) = Nullgv;
3965*0Sstevel@tonic-gate
3966*0Sstevel@tonic-gate pad_undef(cv);
3967*0Sstevel@tonic-gate
3968*0Sstevel@tonic-gate /* remove CvOUTSIDE unless this is an undef rather than a free */
3969*0Sstevel@tonic-gate if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
3970*0Sstevel@tonic-gate if (!CvWEAKOUTSIDE(cv))
3971*0Sstevel@tonic-gate SvREFCNT_dec(CvOUTSIDE(cv));
3972*0Sstevel@tonic-gate CvOUTSIDE(cv) = Nullcv;
3973*0Sstevel@tonic-gate }
3974*0Sstevel@tonic-gate if (CvCONST(cv)) {
3975*0Sstevel@tonic-gate SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
3976*0Sstevel@tonic-gate CvCONST_off(cv);
3977*0Sstevel@tonic-gate }
3978*0Sstevel@tonic-gate if (CvXSUB(cv)) {
3979*0Sstevel@tonic-gate CvXSUB(cv) = 0;
3980*0Sstevel@tonic-gate }
3981*0Sstevel@tonic-gate /* delete all flags except WEAKOUTSIDE */
3982*0Sstevel@tonic-gate CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
3983*0Sstevel@tonic-gate }
3984*0Sstevel@tonic-gate
3985*0Sstevel@tonic-gate void
Perl_cv_ckproto(pTHX_ CV * cv,GV * gv,char * p)3986*0Sstevel@tonic-gate Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
3987*0Sstevel@tonic-gate {
3988*0Sstevel@tonic-gate if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
3989*0Sstevel@tonic-gate SV* msg = sv_newmortal();
3990*0Sstevel@tonic-gate SV* name = Nullsv;
3991*0Sstevel@tonic-gate
3992*0Sstevel@tonic-gate if (gv)
3993*0Sstevel@tonic-gate gv_efullname3(name = sv_newmortal(), gv, Nullch);
3994*0Sstevel@tonic-gate sv_setpv(msg, "Prototype mismatch:");
3995*0Sstevel@tonic-gate if (name)
3996*0Sstevel@tonic-gate Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
3997*0Sstevel@tonic-gate if (SvPOK(cv))
3998*0Sstevel@tonic-gate Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv);
3999*0Sstevel@tonic-gate else
4000*0Sstevel@tonic-gate Perl_sv_catpvf(aTHX_ msg, ": none");
4001*0Sstevel@tonic-gate sv_catpv(msg, " vs ");
4002*0Sstevel@tonic-gate if (p)
4003*0Sstevel@tonic-gate Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4004*0Sstevel@tonic-gate else
4005*0Sstevel@tonic-gate sv_catpv(msg, "none");
4006*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4007*0Sstevel@tonic-gate }
4008*0Sstevel@tonic-gate }
4009*0Sstevel@tonic-gate
4010*0Sstevel@tonic-gate static void const_sv_xsub(pTHX_ CV* cv);
4011*0Sstevel@tonic-gate
4012*0Sstevel@tonic-gate /*
4013*0Sstevel@tonic-gate
4014*0Sstevel@tonic-gate =head1 Optree Manipulation Functions
4015*0Sstevel@tonic-gate
4016*0Sstevel@tonic-gate =for apidoc cv_const_sv
4017*0Sstevel@tonic-gate
4018*0Sstevel@tonic-gate If C<cv> is a constant sub eligible for inlining. returns the constant
4019*0Sstevel@tonic-gate value returned by the sub. Otherwise, returns NULL.
4020*0Sstevel@tonic-gate
4021*0Sstevel@tonic-gate Constant subs can be created with C<newCONSTSUB> or as described in
4022*0Sstevel@tonic-gate L<perlsub/"Constant Functions">.
4023*0Sstevel@tonic-gate
4024*0Sstevel@tonic-gate =cut
4025*0Sstevel@tonic-gate */
4026*0Sstevel@tonic-gate SV *
Perl_cv_const_sv(pTHX_ CV * cv)4027*0Sstevel@tonic-gate Perl_cv_const_sv(pTHX_ CV *cv)
4028*0Sstevel@tonic-gate {
4029*0Sstevel@tonic-gate if (!cv || !CvCONST(cv))
4030*0Sstevel@tonic-gate return Nullsv;
4031*0Sstevel@tonic-gate return (SV*)CvXSUBANY(cv).any_ptr;
4032*0Sstevel@tonic-gate }
4033*0Sstevel@tonic-gate
4034*0Sstevel@tonic-gate SV *
Perl_op_const_sv(pTHX_ OP * o,CV * cv)4035*0Sstevel@tonic-gate Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4036*0Sstevel@tonic-gate {
4037*0Sstevel@tonic-gate SV *sv = Nullsv;
4038*0Sstevel@tonic-gate
4039*0Sstevel@tonic-gate if (!o)
4040*0Sstevel@tonic-gate return Nullsv;
4041*0Sstevel@tonic-gate
4042*0Sstevel@tonic-gate if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4043*0Sstevel@tonic-gate o = cLISTOPo->op_first->op_sibling;
4044*0Sstevel@tonic-gate
4045*0Sstevel@tonic-gate for (; o; o = o->op_next) {
4046*0Sstevel@tonic-gate OPCODE type = o->op_type;
4047*0Sstevel@tonic-gate
4048*0Sstevel@tonic-gate if (sv && o->op_next == o)
4049*0Sstevel@tonic-gate return sv;
4050*0Sstevel@tonic-gate if (o->op_next != o) {
4051*0Sstevel@tonic-gate if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4052*0Sstevel@tonic-gate continue;
4053*0Sstevel@tonic-gate if (type == OP_DBSTATE)
4054*0Sstevel@tonic-gate continue;
4055*0Sstevel@tonic-gate }
4056*0Sstevel@tonic-gate if (type == OP_LEAVESUB || type == OP_RETURN)
4057*0Sstevel@tonic-gate break;
4058*0Sstevel@tonic-gate if (sv)
4059*0Sstevel@tonic-gate return Nullsv;
4060*0Sstevel@tonic-gate if (type == OP_CONST && cSVOPo->op_sv)
4061*0Sstevel@tonic-gate sv = cSVOPo->op_sv;
4062*0Sstevel@tonic-gate else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4063*0Sstevel@tonic-gate sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4064*0Sstevel@tonic-gate if (!sv)
4065*0Sstevel@tonic-gate return Nullsv;
4066*0Sstevel@tonic-gate if (CvCONST(cv)) {
4067*0Sstevel@tonic-gate /* We get here only from cv_clone2() while creating a closure.
4068*0Sstevel@tonic-gate Copy the const value here instead of in cv_clone2 so that
4069*0Sstevel@tonic-gate SvREADONLY_on doesn't lead to problems when leaving
4070*0Sstevel@tonic-gate scope.
4071*0Sstevel@tonic-gate */
4072*0Sstevel@tonic-gate sv = newSVsv(sv);
4073*0Sstevel@tonic-gate }
4074*0Sstevel@tonic-gate if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4075*0Sstevel@tonic-gate return Nullsv;
4076*0Sstevel@tonic-gate }
4077*0Sstevel@tonic-gate else
4078*0Sstevel@tonic-gate return Nullsv;
4079*0Sstevel@tonic-gate }
4080*0Sstevel@tonic-gate if (sv)
4081*0Sstevel@tonic-gate SvREADONLY_on(sv);
4082*0Sstevel@tonic-gate return sv;
4083*0Sstevel@tonic-gate }
4084*0Sstevel@tonic-gate
4085*0Sstevel@tonic-gate void
Perl_newMYSUB(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block)4086*0Sstevel@tonic-gate Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4087*0Sstevel@tonic-gate {
4088*0Sstevel@tonic-gate if (o)
4089*0Sstevel@tonic-gate SAVEFREEOP(o);
4090*0Sstevel@tonic-gate if (proto)
4091*0Sstevel@tonic-gate SAVEFREEOP(proto);
4092*0Sstevel@tonic-gate if (attrs)
4093*0Sstevel@tonic-gate SAVEFREEOP(attrs);
4094*0Sstevel@tonic-gate if (block)
4095*0Sstevel@tonic-gate SAVEFREEOP(block);
4096*0Sstevel@tonic-gate Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4097*0Sstevel@tonic-gate }
4098*0Sstevel@tonic-gate
4099*0Sstevel@tonic-gate CV *
Perl_newSUB(pTHX_ I32 floor,OP * o,OP * proto,OP * block)4100*0Sstevel@tonic-gate Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4101*0Sstevel@tonic-gate {
4102*0Sstevel@tonic-gate return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4103*0Sstevel@tonic-gate }
4104*0Sstevel@tonic-gate
4105*0Sstevel@tonic-gate CV *
Perl_newATTRSUB(pTHX_ I32 floor,OP * o,OP * proto,OP * attrs,OP * block)4106*0Sstevel@tonic-gate Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4107*0Sstevel@tonic-gate {
4108*0Sstevel@tonic-gate STRLEN n_a;
4109*0Sstevel@tonic-gate char *name;
4110*0Sstevel@tonic-gate char *aname;
4111*0Sstevel@tonic-gate GV *gv;
4112*0Sstevel@tonic-gate char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4113*0Sstevel@tonic-gate register CV *cv=0;
4114*0Sstevel@tonic-gate SV *const_sv;
4115*0Sstevel@tonic-gate
4116*0Sstevel@tonic-gate name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4117*0Sstevel@tonic-gate if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4118*0Sstevel@tonic-gate SV *sv = sv_newmortal();
4119*0Sstevel@tonic-gate Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4120*0Sstevel@tonic-gate PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4121*0Sstevel@tonic-gate CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4122*0Sstevel@tonic-gate aname = SvPVX(sv);
4123*0Sstevel@tonic-gate }
4124*0Sstevel@tonic-gate else
4125*0Sstevel@tonic-gate aname = Nullch;
4126*0Sstevel@tonic-gate gv = gv_fetchpv(name ? name : (aname ? aname :
4127*0Sstevel@tonic-gate (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4128*0Sstevel@tonic-gate GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4129*0Sstevel@tonic-gate SVt_PVCV);
4130*0Sstevel@tonic-gate
4131*0Sstevel@tonic-gate if (o)
4132*0Sstevel@tonic-gate SAVEFREEOP(o);
4133*0Sstevel@tonic-gate if (proto)
4134*0Sstevel@tonic-gate SAVEFREEOP(proto);
4135*0Sstevel@tonic-gate if (attrs)
4136*0Sstevel@tonic-gate SAVEFREEOP(attrs);
4137*0Sstevel@tonic-gate
4138*0Sstevel@tonic-gate if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4139*0Sstevel@tonic-gate maximum a prototype before. */
4140*0Sstevel@tonic-gate if (SvTYPE(gv) > SVt_NULL) {
4141*0Sstevel@tonic-gate if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4142*0Sstevel@tonic-gate && ckWARN_d(WARN_PROTOTYPE))
4143*0Sstevel@tonic-gate {
4144*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4145*0Sstevel@tonic-gate }
4146*0Sstevel@tonic-gate cv_ckproto((CV*)gv, NULL, ps);
4147*0Sstevel@tonic-gate }
4148*0Sstevel@tonic-gate if (ps)
4149*0Sstevel@tonic-gate sv_setpv((SV*)gv, ps);
4150*0Sstevel@tonic-gate else
4151*0Sstevel@tonic-gate sv_setiv((SV*)gv, -1);
4152*0Sstevel@tonic-gate SvREFCNT_dec(PL_compcv);
4153*0Sstevel@tonic-gate cv = PL_compcv = NULL;
4154*0Sstevel@tonic-gate PL_sub_generation++;
4155*0Sstevel@tonic-gate goto done;
4156*0Sstevel@tonic-gate }
4157*0Sstevel@tonic-gate
4158*0Sstevel@tonic-gate cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4159*0Sstevel@tonic-gate
4160*0Sstevel@tonic-gate #ifdef GV_UNIQUE_CHECK
4161*0Sstevel@tonic-gate if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4162*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4163*0Sstevel@tonic-gate }
4164*0Sstevel@tonic-gate #endif
4165*0Sstevel@tonic-gate
4166*0Sstevel@tonic-gate if (!block || !ps || *ps || attrs)
4167*0Sstevel@tonic-gate const_sv = Nullsv;
4168*0Sstevel@tonic-gate else
4169*0Sstevel@tonic-gate const_sv = op_const_sv(block, Nullcv);
4170*0Sstevel@tonic-gate
4171*0Sstevel@tonic-gate if (cv) {
4172*0Sstevel@tonic-gate bool exists = CvROOT(cv) || CvXSUB(cv);
4173*0Sstevel@tonic-gate
4174*0Sstevel@tonic-gate #ifdef GV_UNIQUE_CHECK
4175*0Sstevel@tonic-gate if (exists && GvUNIQUE(gv)) {
4176*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4177*0Sstevel@tonic-gate }
4178*0Sstevel@tonic-gate #endif
4179*0Sstevel@tonic-gate
4180*0Sstevel@tonic-gate /* if the subroutine doesn't exist and wasn't pre-declared
4181*0Sstevel@tonic-gate * with a prototype, assume it will be AUTOLOADed,
4182*0Sstevel@tonic-gate * skipping the prototype check
4183*0Sstevel@tonic-gate */
4184*0Sstevel@tonic-gate if (exists || SvPOK(cv))
4185*0Sstevel@tonic-gate cv_ckproto(cv, gv, ps);
4186*0Sstevel@tonic-gate /* already defined (or promised)? */
4187*0Sstevel@tonic-gate if (exists || GvASSUMECV(gv)) {
4188*0Sstevel@tonic-gate if (!block && !attrs) {
4189*0Sstevel@tonic-gate if (CvFLAGS(PL_compcv)) {
4190*0Sstevel@tonic-gate /* might have had built-in attrs applied */
4191*0Sstevel@tonic-gate CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4192*0Sstevel@tonic-gate }
4193*0Sstevel@tonic-gate /* just a "sub foo;" when &foo is already defined */
4194*0Sstevel@tonic-gate SAVEFREESV(PL_compcv);
4195*0Sstevel@tonic-gate goto done;
4196*0Sstevel@tonic-gate }
4197*0Sstevel@tonic-gate /* ahem, death to those who redefine active sort subs */
4198*0Sstevel@tonic-gate if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4199*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4200*0Sstevel@tonic-gate if (block) {
4201*0Sstevel@tonic-gate if (ckWARN(WARN_REDEFINE)
4202*0Sstevel@tonic-gate || (CvCONST(cv)
4203*0Sstevel@tonic-gate && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4204*0Sstevel@tonic-gate {
4205*0Sstevel@tonic-gate line_t oldline = CopLINE(PL_curcop);
4206*0Sstevel@tonic-gate if (PL_copline != NOLINE)
4207*0Sstevel@tonic-gate CopLINE_set(PL_curcop, PL_copline);
4208*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4209*0Sstevel@tonic-gate CvCONST(cv) ? "Constant subroutine %s redefined"
4210*0Sstevel@tonic-gate : "Subroutine %s redefined", name);
4211*0Sstevel@tonic-gate CopLINE_set(PL_curcop, oldline);
4212*0Sstevel@tonic-gate }
4213*0Sstevel@tonic-gate SvREFCNT_dec(cv);
4214*0Sstevel@tonic-gate cv = Nullcv;
4215*0Sstevel@tonic-gate }
4216*0Sstevel@tonic-gate }
4217*0Sstevel@tonic-gate }
4218*0Sstevel@tonic-gate if (const_sv) {
4219*0Sstevel@tonic-gate SvREFCNT_inc(const_sv);
4220*0Sstevel@tonic-gate if (cv) {
4221*0Sstevel@tonic-gate assert(!CvROOT(cv) && !CvCONST(cv));
4222*0Sstevel@tonic-gate sv_setpv((SV*)cv, ""); /* prototype is "" */
4223*0Sstevel@tonic-gate CvXSUBANY(cv).any_ptr = const_sv;
4224*0Sstevel@tonic-gate CvXSUB(cv) = const_sv_xsub;
4225*0Sstevel@tonic-gate CvCONST_on(cv);
4226*0Sstevel@tonic-gate }
4227*0Sstevel@tonic-gate else {
4228*0Sstevel@tonic-gate GvCV(gv) = Nullcv;
4229*0Sstevel@tonic-gate cv = newCONSTSUB(NULL, name, const_sv);
4230*0Sstevel@tonic-gate }
4231*0Sstevel@tonic-gate op_free(block);
4232*0Sstevel@tonic-gate SvREFCNT_dec(PL_compcv);
4233*0Sstevel@tonic-gate PL_compcv = NULL;
4234*0Sstevel@tonic-gate PL_sub_generation++;
4235*0Sstevel@tonic-gate goto done;
4236*0Sstevel@tonic-gate }
4237*0Sstevel@tonic-gate if (attrs) {
4238*0Sstevel@tonic-gate HV *stash;
4239*0Sstevel@tonic-gate SV *rcv;
4240*0Sstevel@tonic-gate
4241*0Sstevel@tonic-gate /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4242*0Sstevel@tonic-gate * before we clobber PL_compcv.
4243*0Sstevel@tonic-gate */
4244*0Sstevel@tonic-gate if (cv && !block) {
4245*0Sstevel@tonic-gate rcv = (SV*)cv;
4246*0Sstevel@tonic-gate /* Might have had built-in attributes applied -- propagate them. */
4247*0Sstevel@tonic-gate CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4248*0Sstevel@tonic-gate if (CvGV(cv) && GvSTASH(CvGV(cv)))
4249*0Sstevel@tonic-gate stash = GvSTASH(CvGV(cv));
4250*0Sstevel@tonic-gate else if (CvSTASH(cv))
4251*0Sstevel@tonic-gate stash = CvSTASH(cv);
4252*0Sstevel@tonic-gate else
4253*0Sstevel@tonic-gate stash = PL_curstash;
4254*0Sstevel@tonic-gate }
4255*0Sstevel@tonic-gate else {
4256*0Sstevel@tonic-gate /* possibly about to re-define existing subr -- ignore old cv */
4257*0Sstevel@tonic-gate rcv = (SV*)PL_compcv;
4258*0Sstevel@tonic-gate if (name && GvSTASH(gv))
4259*0Sstevel@tonic-gate stash = GvSTASH(gv);
4260*0Sstevel@tonic-gate else
4261*0Sstevel@tonic-gate stash = PL_curstash;
4262*0Sstevel@tonic-gate }
4263*0Sstevel@tonic-gate apply_attrs(stash, rcv, attrs, FALSE);
4264*0Sstevel@tonic-gate }
4265*0Sstevel@tonic-gate if (cv) { /* must reuse cv if autoloaded */
4266*0Sstevel@tonic-gate if (!block) {
4267*0Sstevel@tonic-gate /* got here with just attrs -- work done, so bug out */
4268*0Sstevel@tonic-gate SAVEFREESV(PL_compcv);
4269*0Sstevel@tonic-gate goto done;
4270*0Sstevel@tonic-gate }
4271*0Sstevel@tonic-gate /* transfer PL_compcv to cv */
4272*0Sstevel@tonic-gate cv_undef(cv);
4273*0Sstevel@tonic-gate CvFLAGS(cv) = CvFLAGS(PL_compcv);
4274*0Sstevel@tonic-gate if (!CvWEAKOUTSIDE(cv))
4275*0Sstevel@tonic-gate SvREFCNT_dec(CvOUTSIDE(cv));
4276*0Sstevel@tonic-gate CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4277*0Sstevel@tonic-gate CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4278*0Sstevel@tonic-gate CvOUTSIDE(PL_compcv) = 0;
4279*0Sstevel@tonic-gate CvPADLIST(cv) = CvPADLIST(PL_compcv);
4280*0Sstevel@tonic-gate CvPADLIST(PL_compcv) = 0;
4281*0Sstevel@tonic-gate /* inner references to PL_compcv must be fixed up ... */
4282*0Sstevel@tonic-gate pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4283*0Sstevel@tonic-gate /* ... before we throw it away */
4284*0Sstevel@tonic-gate SvREFCNT_dec(PL_compcv);
4285*0Sstevel@tonic-gate if (PERLDB_INTER)/* Advice debugger on the new sub. */
4286*0Sstevel@tonic-gate ++PL_sub_generation;
4287*0Sstevel@tonic-gate }
4288*0Sstevel@tonic-gate else {
4289*0Sstevel@tonic-gate cv = PL_compcv;
4290*0Sstevel@tonic-gate if (name) {
4291*0Sstevel@tonic-gate GvCV(gv) = cv;
4292*0Sstevel@tonic-gate GvCVGEN(gv) = 0;
4293*0Sstevel@tonic-gate PL_sub_generation++;
4294*0Sstevel@tonic-gate }
4295*0Sstevel@tonic-gate }
4296*0Sstevel@tonic-gate CvGV(cv) = gv;
4297*0Sstevel@tonic-gate CvFILE_set_from_cop(cv, PL_curcop);
4298*0Sstevel@tonic-gate CvSTASH(cv) = PL_curstash;
4299*0Sstevel@tonic-gate #ifdef USE_5005THREADS
4300*0Sstevel@tonic-gate CvOWNER(cv) = 0;
4301*0Sstevel@tonic-gate if (!CvMUTEXP(cv)) {
4302*0Sstevel@tonic-gate New(666, CvMUTEXP(cv), 1, perl_mutex);
4303*0Sstevel@tonic-gate MUTEX_INIT(CvMUTEXP(cv));
4304*0Sstevel@tonic-gate }
4305*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
4306*0Sstevel@tonic-gate
4307*0Sstevel@tonic-gate if (ps)
4308*0Sstevel@tonic-gate sv_setpv((SV*)cv, ps);
4309*0Sstevel@tonic-gate
4310*0Sstevel@tonic-gate if (PL_error_count) {
4311*0Sstevel@tonic-gate op_free(block);
4312*0Sstevel@tonic-gate block = Nullop;
4313*0Sstevel@tonic-gate if (name) {
4314*0Sstevel@tonic-gate char *s = strrchr(name, ':');
4315*0Sstevel@tonic-gate s = s ? s+1 : name;
4316*0Sstevel@tonic-gate if (strEQ(s, "BEGIN")) {
4317*0Sstevel@tonic-gate char *not_safe =
4318*0Sstevel@tonic-gate "BEGIN not safe after errors--compilation aborted";
4319*0Sstevel@tonic-gate if (PL_in_eval & EVAL_KEEPERR)
4320*0Sstevel@tonic-gate Perl_croak(aTHX_ not_safe);
4321*0Sstevel@tonic-gate else {
4322*0Sstevel@tonic-gate /* force display of errors found but not reported */
4323*0Sstevel@tonic-gate sv_catpv(ERRSV, not_safe);
4324*0Sstevel@tonic-gate Perl_croak(aTHX_ "%"SVf, ERRSV);
4325*0Sstevel@tonic-gate }
4326*0Sstevel@tonic-gate }
4327*0Sstevel@tonic-gate }
4328*0Sstevel@tonic-gate }
4329*0Sstevel@tonic-gate if (!block)
4330*0Sstevel@tonic-gate goto done;
4331*0Sstevel@tonic-gate
4332*0Sstevel@tonic-gate if (CvLVALUE(cv)) {
4333*0Sstevel@tonic-gate CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4334*0Sstevel@tonic-gate mod(scalarseq(block), OP_LEAVESUBLV));
4335*0Sstevel@tonic-gate }
4336*0Sstevel@tonic-gate else {
4337*0Sstevel@tonic-gate /* This makes sub {}; work as expected. */
4338*0Sstevel@tonic-gate if (block->op_type == OP_STUB) {
4339*0Sstevel@tonic-gate op_free(block);
4340*0Sstevel@tonic-gate block = newSTATEOP(0, Nullch, 0);
4341*0Sstevel@tonic-gate }
4342*0Sstevel@tonic-gate CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4343*0Sstevel@tonic-gate }
4344*0Sstevel@tonic-gate CvROOT(cv)->op_private |= OPpREFCOUNTED;
4345*0Sstevel@tonic-gate OpREFCNT_set(CvROOT(cv), 1);
4346*0Sstevel@tonic-gate CvSTART(cv) = LINKLIST(CvROOT(cv));
4347*0Sstevel@tonic-gate CvROOT(cv)->op_next = 0;
4348*0Sstevel@tonic-gate CALL_PEEP(CvSTART(cv));
4349*0Sstevel@tonic-gate
4350*0Sstevel@tonic-gate /* now that optimizer has done its work, adjust pad values */
4351*0Sstevel@tonic-gate
4352*0Sstevel@tonic-gate pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4353*0Sstevel@tonic-gate
4354*0Sstevel@tonic-gate if (CvCLONE(cv)) {
4355*0Sstevel@tonic-gate assert(!CvCONST(cv));
4356*0Sstevel@tonic-gate if (ps && !*ps && op_const_sv(block, cv))
4357*0Sstevel@tonic-gate CvCONST_on(cv);
4358*0Sstevel@tonic-gate }
4359*0Sstevel@tonic-gate
4360*0Sstevel@tonic-gate if (name || aname) {
4361*0Sstevel@tonic-gate char *s;
4362*0Sstevel@tonic-gate char *tname = (name ? name : aname);
4363*0Sstevel@tonic-gate
4364*0Sstevel@tonic-gate if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4365*0Sstevel@tonic-gate SV *sv = NEWSV(0,0);
4366*0Sstevel@tonic-gate SV *tmpstr = sv_newmortal();
4367*0Sstevel@tonic-gate GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4368*0Sstevel@tonic-gate CV *pcv;
4369*0Sstevel@tonic-gate HV *hv;
4370*0Sstevel@tonic-gate
4371*0Sstevel@tonic-gate Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4372*0Sstevel@tonic-gate CopFILE(PL_curcop),
4373*0Sstevel@tonic-gate (long)PL_subline, (long)CopLINE(PL_curcop));
4374*0Sstevel@tonic-gate gv_efullname3(tmpstr, gv, Nullch);
4375*0Sstevel@tonic-gate hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4376*0Sstevel@tonic-gate hv = GvHVn(db_postponed);
4377*0Sstevel@tonic-gate if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4378*0Sstevel@tonic-gate && (pcv = GvCV(db_postponed)))
4379*0Sstevel@tonic-gate {
4380*0Sstevel@tonic-gate dSP;
4381*0Sstevel@tonic-gate PUSHMARK(SP);
4382*0Sstevel@tonic-gate XPUSHs(tmpstr);
4383*0Sstevel@tonic-gate PUTBACK;
4384*0Sstevel@tonic-gate call_sv((SV*)pcv, G_DISCARD);
4385*0Sstevel@tonic-gate }
4386*0Sstevel@tonic-gate }
4387*0Sstevel@tonic-gate
4388*0Sstevel@tonic-gate if ((s = strrchr(tname,':')))
4389*0Sstevel@tonic-gate s++;
4390*0Sstevel@tonic-gate else
4391*0Sstevel@tonic-gate s = tname;
4392*0Sstevel@tonic-gate
4393*0Sstevel@tonic-gate if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4394*0Sstevel@tonic-gate goto done;
4395*0Sstevel@tonic-gate
4396*0Sstevel@tonic-gate if (strEQ(s, "BEGIN")) {
4397*0Sstevel@tonic-gate I32 oldscope = PL_scopestack_ix;
4398*0Sstevel@tonic-gate ENTER;
4399*0Sstevel@tonic-gate SAVECOPFILE(&PL_compiling);
4400*0Sstevel@tonic-gate SAVECOPLINE(&PL_compiling);
4401*0Sstevel@tonic-gate
4402*0Sstevel@tonic-gate if (!PL_beginav)
4403*0Sstevel@tonic-gate PL_beginav = newAV();
4404*0Sstevel@tonic-gate DEBUG_x( dump_sub(gv) );
4405*0Sstevel@tonic-gate av_push(PL_beginav, (SV*)cv);
4406*0Sstevel@tonic-gate GvCV(gv) = 0; /* cv has been hijacked */
4407*0Sstevel@tonic-gate call_list(oldscope, PL_beginav);
4408*0Sstevel@tonic-gate
4409*0Sstevel@tonic-gate PL_curcop = &PL_compiling;
4410*0Sstevel@tonic-gate PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4411*0Sstevel@tonic-gate LEAVE;
4412*0Sstevel@tonic-gate }
4413*0Sstevel@tonic-gate else if (strEQ(s, "END") && !PL_error_count) {
4414*0Sstevel@tonic-gate if (!PL_endav)
4415*0Sstevel@tonic-gate PL_endav = newAV();
4416*0Sstevel@tonic-gate DEBUG_x( dump_sub(gv) );
4417*0Sstevel@tonic-gate av_unshift(PL_endav, 1);
4418*0Sstevel@tonic-gate av_store(PL_endav, 0, (SV*)cv);
4419*0Sstevel@tonic-gate GvCV(gv) = 0; /* cv has been hijacked */
4420*0Sstevel@tonic-gate }
4421*0Sstevel@tonic-gate else if (strEQ(s, "CHECK") && !PL_error_count) {
4422*0Sstevel@tonic-gate if (!PL_checkav)
4423*0Sstevel@tonic-gate PL_checkav = newAV();
4424*0Sstevel@tonic-gate DEBUG_x( dump_sub(gv) );
4425*0Sstevel@tonic-gate if (PL_main_start && ckWARN(WARN_VOID))
4426*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4427*0Sstevel@tonic-gate av_unshift(PL_checkav, 1);
4428*0Sstevel@tonic-gate av_store(PL_checkav, 0, (SV*)cv);
4429*0Sstevel@tonic-gate GvCV(gv) = 0; /* cv has been hijacked */
4430*0Sstevel@tonic-gate }
4431*0Sstevel@tonic-gate else if (strEQ(s, "INIT") && !PL_error_count) {
4432*0Sstevel@tonic-gate if (!PL_initav)
4433*0Sstevel@tonic-gate PL_initav = newAV();
4434*0Sstevel@tonic-gate DEBUG_x( dump_sub(gv) );
4435*0Sstevel@tonic-gate if (PL_main_start && ckWARN(WARN_VOID))
4436*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4437*0Sstevel@tonic-gate av_push(PL_initav, (SV*)cv);
4438*0Sstevel@tonic-gate GvCV(gv) = 0; /* cv has been hijacked */
4439*0Sstevel@tonic-gate }
4440*0Sstevel@tonic-gate }
4441*0Sstevel@tonic-gate
4442*0Sstevel@tonic-gate done:
4443*0Sstevel@tonic-gate PL_copline = NOLINE;
4444*0Sstevel@tonic-gate LEAVE_SCOPE(floor);
4445*0Sstevel@tonic-gate return cv;
4446*0Sstevel@tonic-gate }
4447*0Sstevel@tonic-gate
4448*0Sstevel@tonic-gate /* XXX unsafe for threads if eval_owner isn't held */
4449*0Sstevel@tonic-gate /*
4450*0Sstevel@tonic-gate =for apidoc newCONSTSUB
4451*0Sstevel@tonic-gate
4452*0Sstevel@tonic-gate Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4453*0Sstevel@tonic-gate eligible for inlining at compile-time.
4454*0Sstevel@tonic-gate
4455*0Sstevel@tonic-gate =cut
4456*0Sstevel@tonic-gate */
4457*0Sstevel@tonic-gate
4458*0Sstevel@tonic-gate CV *
Perl_newCONSTSUB(pTHX_ HV * stash,char * name,SV * sv)4459*0Sstevel@tonic-gate Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4460*0Sstevel@tonic-gate {
4461*0Sstevel@tonic-gate CV* cv;
4462*0Sstevel@tonic-gate
4463*0Sstevel@tonic-gate ENTER;
4464*0Sstevel@tonic-gate
4465*0Sstevel@tonic-gate SAVECOPLINE(PL_curcop);
4466*0Sstevel@tonic-gate CopLINE_set(PL_curcop, PL_copline);
4467*0Sstevel@tonic-gate
4468*0Sstevel@tonic-gate SAVEHINTS();
4469*0Sstevel@tonic-gate PL_hints &= ~HINT_BLOCK_SCOPE;
4470*0Sstevel@tonic-gate
4471*0Sstevel@tonic-gate if (stash) {
4472*0Sstevel@tonic-gate SAVESPTR(PL_curstash);
4473*0Sstevel@tonic-gate SAVECOPSTASH(PL_curcop);
4474*0Sstevel@tonic-gate PL_curstash = stash;
4475*0Sstevel@tonic-gate CopSTASH_set(PL_curcop,stash);
4476*0Sstevel@tonic-gate }
4477*0Sstevel@tonic-gate
4478*0Sstevel@tonic-gate cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4479*0Sstevel@tonic-gate CvXSUBANY(cv).any_ptr = sv;
4480*0Sstevel@tonic-gate CvCONST_on(cv);
4481*0Sstevel@tonic-gate sv_setpv((SV*)cv, ""); /* prototype is "" */
4482*0Sstevel@tonic-gate
4483*0Sstevel@tonic-gate if (stash)
4484*0Sstevel@tonic-gate CopSTASH_free(PL_curcop);
4485*0Sstevel@tonic-gate
4486*0Sstevel@tonic-gate LEAVE;
4487*0Sstevel@tonic-gate
4488*0Sstevel@tonic-gate return cv;
4489*0Sstevel@tonic-gate }
4490*0Sstevel@tonic-gate
4491*0Sstevel@tonic-gate /*
4492*0Sstevel@tonic-gate =for apidoc U||newXS
4493*0Sstevel@tonic-gate
4494*0Sstevel@tonic-gate Used by C<xsubpp> to hook up XSUBs as Perl subs.
4495*0Sstevel@tonic-gate
4496*0Sstevel@tonic-gate =cut
4497*0Sstevel@tonic-gate */
4498*0Sstevel@tonic-gate
4499*0Sstevel@tonic-gate CV *
Perl_newXS(pTHX_ char * name,XSUBADDR_t subaddr,char * filename)4500*0Sstevel@tonic-gate Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4501*0Sstevel@tonic-gate {
4502*0Sstevel@tonic-gate GV *gv = gv_fetchpv(name ? name :
4503*0Sstevel@tonic-gate (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4504*0Sstevel@tonic-gate GV_ADDMULTI, SVt_PVCV);
4505*0Sstevel@tonic-gate register CV *cv;
4506*0Sstevel@tonic-gate
4507*0Sstevel@tonic-gate if ((cv = (name ? GvCV(gv) : Nullcv))) {
4508*0Sstevel@tonic-gate if (GvCVGEN(gv)) {
4509*0Sstevel@tonic-gate /* just a cached method */
4510*0Sstevel@tonic-gate SvREFCNT_dec(cv);
4511*0Sstevel@tonic-gate cv = 0;
4512*0Sstevel@tonic-gate }
4513*0Sstevel@tonic-gate else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4514*0Sstevel@tonic-gate /* already defined (or promised) */
4515*0Sstevel@tonic-gate if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4516*0Sstevel@tonic-gate && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4517*0Sstevel@tonic-gate line_t oldline = CopLINE(PL_curcop);
4518*0Sstevel@tonic-gate if (PL_copline != NOLINE)
4519*0Sstevel@tonic-gate CopLINE_set(PL_curcop, PL_copline);
4520*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4521*0Sstevel@tonic-gate CvCONST(cv) ? "Constant subroutine %s redefined"
4522*0Sstevel@tonic-gate : "Subroutine %s redefined"
4523*0Sstevel@tonic-gate ,name);
4524*0Sstevel@tonic-gate CopLINE_set(PL_curcop, oldline);
4525*0Sstevel@tonic-gate }
4526*0Sstevel@tonic-gate SvREFCNT_dec(cv);
4527*0Sstevel@tonic-gate cv = 0;
4528*0Sstevel@tonic-gate }
4529*0Sstevel@tonic-gate }
4530*0Sstevel@tonic-gate
4531*0Sstevel@tonic-gate if (cv) /* must reuse cv if autoloaded */
4532*0Sstevel@tonic-gate cv_undef(cv);
4533*0Sstevel@tonic-gate else {
4534*0Sstevel@tonic-gate cv = (CV*)NEWSV(1105,0);
4535*0Sstevel@tonic-gate sv_upgrade((SV *)cv, SVt_PVCV);
4536*0Sstevel@tonic-gate if (name) {
4537*0Sstevel@tonic-gate GvCV(gv) = cv;
4538*0Sstevel@tonic-gate GvCVGEN(gv) = 0;
4539*0Sstevel@tonic-gate PL_sub_generation++;
4540*0Sstevel@tonic-gate }
4541*0Sstevel@tonic-gate }
4542*0Sstevel@tonic-gate CvGV(cv) = gv;
4543*0Sstevel@tonic-gate #ifdef USE_5005THREADS
4544*0Sstevel@tonic-gate New(666, CvMUTEXP(cv), 1, perl_mutex);
4545*0Sstevel@tonic-gate MUTEX_INIT(CvMUTEXP(cv));
4546*0Sstevel@tonic-gate CvOWNER(cv) = 0;
4547*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
4548*0Sstevel@tonic-gate (void)gv_fetchfile(filename);
4549*0Sstevel@tonic-gate CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
4550*0Sstevel@tonic-gate an external constant string */
4551*0Sstevel@tonic-gate CvXSUB(cv) = subaddr;
4552*0Sstevel@tonic-gate
4553*0Sstevel@tonic-gate if (name) {
4554*0Sstevel@tonic-gate char *s = strrchr(name,':');
4555*0Sstevel@tonic-gate if (s)
4556*0Sstevel@tonic-gate s++;
4557*0Sstevel@tonic-gate else
4558*0Sstevel@tonic-gate s = name;
4559*0Sstevel@tonic-gate
4560*0Sstevel@tonic-gate if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4561*0Sstevel@tonic-gate goto done;
4562*0Sstevel@tonic-gate
4563*0Sstevel@tonic-gate if (strEQ(s, "BEGIN")) {
4564*0Sstevel@tonic-gate if (!PL_beginav)
4565*0Sstevel@tonic-gate PL_beginav = newAV();
4566*0Sstevel@tonic-gate av_push(PL_beginav, (SV*)cv);
4567*0Sstevel@tonic-gate GvCV(gv) = 0; /* cv has been hijacked */
4568*0Sstevel@tonic-gate }
4569*0Sstevel@tonic-gate else if (strEQ(s, "END")) {
4570*0Sstevel@tonic-gate if (!PL_endav)
4571*0Sstevel@tonic-gate PL_endav = newAV();
4572*0Sstevel@tonic-gate av_unshift(PL_endav, 1);
4573*0Sstevel@tonic-gate av_store(PL_endav, 0, (SV*)cv);
4574*0Sstevel@tonic-gate GvCV(gv) = 0; /* cv has been hijacked */
4575*0Sstevel@tonic-gate }
4576*0Sstevel@tonic-gate else if (strEQ(s, "CHECK")) {
4577*0Sstevel@tonic-gate if (!PL_checkav)
4578*0Sstevel@tonic-gate PL_checkav = newAV();
4579*0Sstevel@tonic-gate if (PL_main_start && ckWARN(WARN_VOID))
4580*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4581*0Sstevel@tonic-gate av_unshift(PL_checkav, 1);
4582*0Sstevel@tonic-gate av_store(PL_checkav, 0, (SV*)cv);
4583*0Sstevel@tonic-gate GvCV(gv) = 0; /* cv has been hijacked */
4584*0Sstevel@tonic-gate }
4585*0Sstevel@tonic-gate else if (strEQ(s, "INIT")) {
4586*0Sstevel@tonic-gate if (!PL_initav)
4587*0Sstevel@tonic-gate PL_initav = newAV();
4588*0Sstevel@tonic-gate if (PL_main_start && ckWARN(WARN_VOID))
4589*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4590*0Sstevel@tonic-gate av_push(PL_initav, (SV*)cv);
4591*0Sstevel@tonic-gate GvCV(gv) = 0; /* cv has been hijacked */
4592*0Sstevel@tonic-gate }
4593*0Sstevel@tonic-gate }
4594*0Sstevel@tonic-gate else
4595*0Sstevel@tonic-gate CvANON_on(cv);
4596*0Sstevel@tonic-gate
4597*0Sstevel@tonic-gate done:
4598*0Sstevel@tonic-gate return cv;
4599*0Sstevel@tonic-gate }
4600*0Sstevel@tonic-gate
4601*0Sstevel@tonic-gate void
Perl_newFORM(pTHX_ I32 floor,OP * o,OP * block)4602*0Sstevel@tonic-gate Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4603*0Sstevel@tonic-gate {
4604*0Sstevel@tonic-gate register CV *cv;
4605*0Sstevel@tonic-gate char *name;
4606*0Sstevel@tonic-gate GV *gv;
4607*0Sstevel@tonic-gate STRLEN n_a;
4608*0Sstevel@tonic-gate
4609*0Sstevel@tonic-gate if (o)
4610*0Sstevel@tonic-gate name = SvPVx(cSVOPo->op_sv, n_a);
4611*0Sstevel@tonic-gate else
4612*0Sstevel@tonic-gate name = "STDOUT";
4613*0Sstevel@tonic-gate gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4614*0Sstevel@tonic-gate #ifdef GV_UNIQUE_CHECK
4615*0Sstevel@tonic-gate if (GvUNIQUE(gv)) {
4616*0Sstevel@tonic-gate Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4617*0Sstevel@tonic-gate }
4618*0Sstevel@tonic-gate #endif
4619*0Sstevel@tonic-gate GvMULTI_on(gv);
4620*0Sstevel@tonic-gate if ((cv = GvFORM(gv))) {
4621*0Sstevel@tonic-gate if (ckWARN(WARN_REDEFINE)) {
4622*0Sstevel@tonic-gate line_t oldline = CopLINE(PL_curcop);
4623*0Sstevel@tonic-gate if (PL_copline != NOLINE)
4624*0Sstevel@tonic-gate CopLINE_set(PL_curcop, PL_copline);
4625*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
4626*0Sstevel@tonic-gate CopLINE_set(PL_curcop, oldline);
4627*0Sstevel@tonic-gate }
4628*0Sstevel@tonic-gate SvREFCNT_dec(cv);
4629*0Sstevel@tonic-gate }
4630*0Sstevel@tonic-gate cv = PL_compcv;
4631*0Sstevel@tonic-gate GvFORM(gv) = cv;
4632*0Sstevel@tonic-gate CvGV(cv) = gv;
4633*0Sstevel@tonic-gate CvFILE_set_from_cop(cv, PL_curcop);
4634*0Sstevel@tonic-gate
4635*0Sstevel@tonic-gate
4636*0Sstevel@tonic-gate pad_tidy(padtidy_FORMAT);
4637*0Sstevel@tonic-gate CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4638*0Sstevel@tonic-gate CvROOT(cv)->op_private |= OPpREFCOUNTED;
4639*0Sstevel@tonic-gate OpREFCNT_set(CvROOT(cv), 1);
4640*0Sstevel@tonic-gate CvSTART(cv) = LINKLIST(CvROOT(cv));
4641*0Sstevel@tonic-gate CvROOT(cv)->op_next = 0;
4642*0Sstevel@tonic-gate CALL_PEEP(CvSTART(cv));
4643*0Sstevel@tonic-gate op_free(o);
4644*0Sstevel@tonic-gate PL_copline = NOLINE;
4645*0Sstevel@tonic-gate LEAVE_SCOPE(floor);
4646*0Sstevel@tonic-gate }
4647*0Sstevel@tonic-gate
4648*0Sstevel@tonic-gate OP *
Perl_newANONLIST(pTHX_ OP * o)4649*0Sstevel@tonic-gate Perl_newANONLIST(pTHX_ OP *o)
4650*0Sstevel@tonic-gate {
4651*0Sstevel@tonic-gate return newUNOP(OP_REFGEN, 0,
4652*0Sstevel@tonic-gate mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4653*0Sstevel@tonic-gate }
4654*0Sstevel@tonic-gate
4655*0Sstevel@tonic-gate OP *
Perl_newANONHASH(pTHX_ OP * o)4656*0Sstevel@tonic-gate Perl_newANONHASH(pTHX_ OP *o)
4657*0Sstevel@tonic-gate {
4658*0Sstevel@tonic-gate return newUNOP(OP_REFGEN, 0,
4659*0Sstevel@tonic-gate mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4660*0Sstevel@tonic-gate }
4661*0Sstevel@tonic-gate
4662*0Sstevel@tonic-gate OP *
Perl_newANONSUB(pTHX_ I32 floor,OP * proto,OP * block)4663*0Sstevel@tonic-gate Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4664*0Sstevel@tonic-gate {
4665*0Sstevel@tonic-gate return newANONATTRSUB(floor, proto, Nullop, block);
4666*0Sstevel@tonic-gate }
4667*0Sstevel@tonic-gate
4668*0Sstevel@tonic-gate OP *
Perl_newANONATTRSUB(pTHX_ I32 floor,OP * proto,OP * attrs,OP * block)4669*0Sstevel@tonic-gate Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4670*0Sstevel@tonic-gate {
4671*0Sstevel@tonic-gate return newUNOP(OP_REFGEN, 0,
4672*0Sstevel@tonic-gate newSVOP(OP_ANONCODE, 0,
4673*0Sstevel@tonic-gate (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4674*0Sstevel@tonic-gate }
4675*0Sstevel@tonic-gate
4676*0Sstevel@tonic-gate OP *
Perl_oopsAV(pTHX_ OP * o)4677*0Sstevel@tonic-gate Perl_oopsAV(pTHX_ OP *o)
4678*0Sstevel@tonic-gate {
4679*0Sstevel@tonic-gate switch (o->op_type) {
4680*0Sstevel@tonic-gate case OP_PADSV:
4681*0Sstevel@tonic-gate o->op_type = OP_PADAV;
4682*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_PADAV];
4683*0Sstevel@tonic-gate return ref(o, OP_RV2AV);
4684*0Sstevel@tonic-gate
4685*0Sstevel@tonic-gate case OP_RV2SV:
4686*0Sstevel@tonic-gate o->op_type = OP_RV2AV;
4687*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_RV2AV];
4688*0Sstevel@tonic-gate ref(o, OP_RV2AV);
4689*0Sstevel@tonic-gate break;
4690*0Sstevel@tonic-gate
4691*0Sstevel@tonic-gate default:
4692*0Sstevel@tonic-gate if (ckWARN_d(WARN_INTERNAL))
4693*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
4694*0Sstevel@tonic-gate break;
4695*0Sstevel@tonic-gate }
4696*0Sstevel@tonic-gate return o;
4697*0Sstevel@tonic-gate }
4698*0Sstevel@tonic-gate
4699*0Sstevel@tonic-gate OP *
Perl_oopsHV(pTHX_ OP * o)4700*0Sstevel@tonic-gate Perl_oopsHV(pTHX_ OP *o)
4701*0Sstevel@tonic-gate {
4702*0Sstevel@tonic-gate switch (o->op_type) {
4703*0Sstevel@tonic-gate case OP_PADSV:
4704*0Sstevel@tonic-gate case OP_PADAV:
4705*0Sstevel@tonic-gate o->op_type = OP_PADHV;
4706*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_PADHV];
4707*0Sstevel@tonic-gate return ref(o, OP_RV2HV);
4708*0Sstevel@tonic-gate
4709*0Sstevel@tonic-gate case OP_RV2SV:
4710*0Sstevel@tonic-gate case OP_RV2AV:
4711*0Sstevel@tonic-gate o->op_type = OP_RV2HV;
4712*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_RV2HV];
4713*0Sstevel@tonic-gate ref(o, OP_RV2HV);
4714*0Sstevel@tonic-gate break;
4715*0Sstevel@tonic-gate
4716*0Sstevel@tonic-gate default:
4717*0Sstevel@tonic-gate if (ckWARN_d(WARN_INTERNAL))
4718*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
4719*0Sstevel@tonic-gate break;
4720*0Sstevel@tonic-gate }
4721*0Sstevel@tonic-gate return o;
4722*0Sstevel@tonic-gate }
4723*0Sstevel@tonic-gate
4724*0Sstevel@tonic-gate OP *
Perl_newAVREF(pTHX_ OP * o)4725*0Sstevel@tonic-gate Perl_newAVREF(pTHX_ OP *o)
4726*0Sstevel@tonic-gate {
4727*0Sstevel@tonic-gate if (o->op_type == OP_PADANY) {
4728*0Sstevel@tonic-gate o->op_type = OP_PADAV;
4729*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_PADAV];
4730*0Sstevel@tonic-gate return o;
4731*0Sstevel@tonic-gate }
4732*0Sstevel@tonic-gate else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
4733*0Sstevel@tonic-gate && ckWARN(WARN_DEPRECATED)) {
4734*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4735*0Sstevel@tonic-gate "Using an array as a reference is deprecated");
4736*0Sstevel@tonic-gate }
4737*0Sstevel@tonic-gate return newUNOP(OP_RV2AV, 0, scalar(o));
4738*0Sstevel@tonic-gate }
4739*0Sstevel@tonic-gate
4740*0Sstevel@tonic-gate OP *
Perl_newGVREF(pTHX_ I32 type,OP * o)4741*0Sstevel@tonic-gate Perl_newGVREF(pTHX_ I32 type, OP *o)
4742*0Sstevel@tonic-gate {
4743*0Sstevel@tonic-gate if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
4744*0Sstevel@tonic-gate return newUNOP(OP_NULL, 0, o);
4745*0Sstevel@tonic-gate return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4746*0Sstevel@tonic-gate }
4747*0Sstevel@tonic-gate
4748*0Sstevel@tonic-gate OP *
Perl_newHVREF(pTHX_ OP * o)4749*0Sstevel@tonic-gate Perl_newHVREF(pTHX_ OP *o)
4750*0Sstevel@tonic-gate {
4751*0Sstevel@tonic-gate if (o->op_type == OP_PADANY) {
4752*0Sstevel@tonic-gate o->op_type = OP_PADHV;
4753*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_PADHV];
4754*0Sstevel@tonic-gate return o;
4755*0Sstevel@tonic-gate }
4756*0Sstevel@tonic-gate else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
4757*0Sstevel@tonic-gate && ckWARN(WARN_DEPRECATED)) {
4758*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4759*0Sstevel@tonic-gate "Using a hash as a reference is deprecated");
4760*0Sstevel@tonic-gate }
4761*0Sstevel@tonic-gate return newUNOP(OP_RV2HV, 0, scalar(o));
4762*0Sstevel@tonic-gate }
4763*0Sstevel@tonic-gate
4764*0Sstevel@tonic-gate OP *
Perl_oopsCV(pTHX_ OP * o)4765*0Sstevel@tonic-gate Perl_oopsCV(pTHX_ OP *o)
4766*0Sstevel@tonic-gate {
4767*0Sstevel@tonic-gate Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
4768*0Sstevel@tonic-gate /* STUB */
4769*0Sstevel@tonic-gate return o;
4770*0Sstevel@tonic-gate }
4771*0Sstevel@tonic-gate
4772*0Sstevel@tonic-gate OP *
Perl_newCVREF(pTHX_ I32 flags,OP * o)4773*0Sstevel@tonic-gate Perl_newCVREF(pTHX_ I32 flags, OP *o)
4774*0Sstevel@tonic-gate {
4775*0Sstevel@tonic-gate return newUNOP(OP_RV2CV, flags, scalar(o));
4776*0Sstevel@tonic-gate }
4777*0Sstevel@tonic-gate
4778*0Sstevel@tonic-gate OP *
Perl_newSVREF(pTHX_ OP * o)4779*0Sstevel@tonic-gate Perl_newSVREF(pTHX_ OP *o)
4780*0Sstevel@tonic-gate {
4781*0Sstevel@tonic-gate if (o->op_type == OP_PADANY) {
4782*0Sstevel@tonic-gate o->op_type = OP_PADSV;
4783*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_PADSV];
4784*0Sstevel@tonic-gate return o;
4785*0Sstevel@tonic-gate }
4786*0Sstevel@tonic-gate else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4787*0Sstevel@tonic-gate o->op_flags |= OPpDONE_SVREF;
4788*0Sstevel@tonic-gate return o;
4789*0Sstevel@tonic-gate }
4790*0Sstevel@tonic-gate return newUNOP(OP_RV2SV, 0, scalar(o));
4791*0Sstevel@tonic-gate }
4792*0Sstevel@tonic-gate
4793*0Sstevel@tonic-gate /* Check routines. */
4794*0Sstevel@tonic-gate
4795*0Sstevel@tonic-gate OP *
Perl_ck_anoncode(pTHX_ OP * o)4796*0Sstevel@tonic-gate Perl_ck_anoncode(pTHX_ OP *o)
4797*0Sstevel@tonic-gate {
4798*0Sstevel@tonic-gate cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
4799*0Sstevel@tonic-gate cSVOPo->op_sv = Nullsv;
4800*0Sstevel@tonic-gate return o;
4801*0Sstevel@tonic-gate }
4802*0Sstevel@tonic-gate
4803*0Sstevel@tonic-gate OP *
Perl_ck_bitop(pTHX_ OP * o)4804*0Sstevel@tonic-gate Perl_ck_bitop(pTHX_ OP *o)
4805*0Sstevel@tonic-gate {
4806*0Sstevel@tonic-gate #define OP_IS_NUMCOMPARE(op) \
4807*0Sstevel@tonic-gate ((op) == OP_LT || (op) == OP_I_LT || \
4808*0Sstevel@tonic-gate (op) == OP_GT || (op) == OP_I_GT || \
4809*0Sstevel@tonic-gate (op) == OP_LE || (op) == OP_I_LE || \
4810*0Sstevel@tonic-gate (op) == OP_GE || (op) == OP_I_GE || \
4811*0Sstevel@tonic-gate (op) == OP_EQ || (op) == OP_I_EQ || \
4812*0Sstevel@tonic-gate (op) == OP_NE || (op) == OP_I_NE || \
4813*0Sstevel@tonic-gate (op) == OP_NCMP || (op) == OP_I_NCMP)
4814*0Sstevel@tonic-gate o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4815*0Sstevel@tonic-gate if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
4816*0Sstevel@tonic-gate && (o->op_type == OP_BIT_OR
4817*0Sstevel@tonic-gate || o->op_type == OP_BIT_AND
4818*0Sstevel@tonic-gate || o->op_type == OP_BIT_XOR))
4819*0Sstevel@tonic-gate {
4820*0Sstevel@tonic-gate OP * left = cBINOPo->op_first;
4821*0Sstevel@tonic-gate OP * right = left->op_sibling;
4822*0Sstevel@tonic-gate if ((OP_IS_NUMCOMPARE(left->op_type) &&
4823*0Sstevel@tonic-gate (left->op_flags & OPf_PARENS) == 0) ||
4824*0Sstevel@tonic-gate (OP_IS_NUMCOMPARE(right->op_type) &&
4825*0Sstevel@tonic-gate (right->op_flags & OPf_PARENS) == 0))
4826*0Sstevel@tonic-gate if (ckWARN(WARN_PRECEDENCE))
4827*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4828*0Sstevel@tonic-gate "Possible precedence problem on bitwise %c operator",
4829*0Sstevel@tonic-gate o->op_type == OP_BIT_OR ? '|'
4830*0Sstevel@tonic-gate : o->op_type == OP_BIT_AND ? '&' : '^'
4831*0Sstevel@tonic-gate );
4832*0Sstevel@tonic-gate }
4833*0Sstevel@tonic-gate return o;
4834*0Sstevel@tonic-gate }
4835*0Sstevel@tonic-gate
4836*0Sstevel@tonic-gate OP *
Perl_ck_concat(pTHX_ OP * o)4837*0Sstevel@tonic-gate Perl_ck_concat(pTHX_ OP *o)
4838*0Sstevel@tonic-gate {
4839*0Sstevel@tonic-gate OP *kid = cUNOPo->op_first;
4840*0Sstevel@tonic-gate if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
4841*0Sstevel@tonic-gate !(kUNOP->op_first->op_flags & OPf_MOD))
4842*0Sstevel@tonic-gate o->op_flags |= OPf_STACKED;
4843*0Sstevel@tonic-gate return o;
4844*0Sstevel@tonic-gate }
4845*0Sstevel@tonic-gate
4846*0Sstevel@tonic-gate OP *
Perl_ck_spair(pTHX_ OP * o)4847*0Sstevel@tonic-gate Perl_ck_spair(pTHX_ OP *o)
4848*0Sstevel@tonic-gate {
4849*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
4850*0Sstevel@tonic-gate OP* newop;
4851*0Sstevel@tonic-gate OP* kid;
4852*0Sstevel@tonic-gate OPCODE type = o->op_type;
4853*0Sstevel@tonic-gate o = modkids(ck_fun(o), type);
4854*0Sstevel@tonic-gate kid = cUNOPo->op_first;
4855*0Sstevel@tonic-gate newop = kUNOP->op_first->op_sibling;
4856*0Sstevel@tonic-gate if (newop &&
4857*0Sstevel@tonic-gate (newop->op_sibling ||
4858*0Sstevel@tonic-gate !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
4859*0Sstevel@tonic-gate newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4860*0Sstevel@tonic-gate newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4861*0Sstevel@tonic-gate
4862*0Sstevel@tonic-gate return o;
4863*0Sstevel@tonic-gate }
4864*0Sstevel@tonic-gate op_free(kUNOP->op_first);
4865*0Sstevel@tonic-gate kUNOP->op_first = newop;
4866*0Sstevel@tonic-gate }
4867*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[++o->op_type];
4868*0Sstevel@tonic-gate return ck_fun(o);
4869*0Sstevel@tonic-gate }
4870*0Sstevel@tonic-gate
4871*0Sstevel@tonic-gate OP *
Perl_ck_delete(pTHX_ OP * o)4872*0Sstevel@tonic-gate Perl_ck_delete(pTHX_ OP *o)
4873*0Sstevel@tonic-gate {
4874*0Sstevel@tonic-gate o = ck_fun(o);
4875*0Sstevel@tonic-gate o->op_private = 0;
4876*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
4877*0Sstevel@tonic-gate OP *kid = cUNOPo->op_first;
4878*0Sstevel@tonic-gate switch (kid->op_type) {
4879*0Sstevel@tonic-gate case OP_ASLICE:
4880*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL;
4881*0Sstevel@tonic-gate /* FALL THROUGH */
4882*0Sstevel@tonic-gate case OP_HSLICE:
4883*0Sstevel@tonic-gate o->op_private |= OPpSLICE;
4884*0Sstevel@tonic-gate break;
4885*0Sstevel@tonic-gate case OP_AELEM:
4886*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL;
4887*0Sstevel@tonic-gate /* FALL THROUGH */
4888*0Sstevel@tonic-gate case OP_HELEM:
4889*0Sstevel@tonic-gate break;
4890*0Sstevel@tonic-gate default:
4891*0Sstevel@tonic-gate Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
4892*0Sstevel@tonic-gate OP_DESC(o));
4893*0Sstevel@tonic-gate }
4894*0Sstevel@tonic-gate op_null(kid);
4895*0Sstevel@tonic-gate }
4896*0Sstevel@tonic-gate return o;
4897*0Sstevel@tonic-gate }
4898*0Sstevel@tonic-gate
4899*0Sstevel@tonic-gate OP *
Perl_ck_die(pTHX_ OP * o)4900*0Sstevel@tonic-gate Perl_ck_die(pTHX_ OP *o)
4901*0Sstevel@tonic-gate {
4902*0Sstevel@tonic-gate #ifdef VMS
4903*0Sstevel@tonic-gate if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4904*0Sstevel@tonic-gate #endif
4905*0Sstevel@tonic-gate return ck_fun(o);
4906*0Sstevel@tonic-gate }
4907*0Sstevel@tonic-gate
4908*0Sstevel@tonic-gate OP *
Perl_ck_eof(pTHX_ OP * o)4909*0Sstevel@tonic-gate Perl_ck_eof(pTHX_ OP *o)
4910*0Sstevel@tonic-gate {
4911*0Sstevel@tonic-gate I32 type = o->op_type;
4912*0Sstevel@tonic-gate
4913*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
4914*0Sstevel@tonic-gate if (cLISTOPo->op_first->op_type == OP_STUB) {
4915*0Sstevel@tonic-gate op_free(o);
4916*0Sstevel@tonic-gate o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
4917*0Sstevel@tonic-gate }
4918*0Sstevel@tonic-gate return ck_fun(o);
4919*0Sstevel@tonic-gate }
4920*0Sstevel@tonic-gate return o;
4921*0Sstevel@tonic-gate }
4922*0Sstevel@tonic-gate
4923*0Sstevel@tonic-gate OP *
Perl_ck_eval(pTHX_ OP * o)4924*0Sstevel@tonic-gate Perl_ck_eval(pTHX_ OP *o)
4925*0Sstevel@tonic-gate {
4926*0Sstevel@tonic-gate PL_hints |= HINT_BLOCK_SCOPE;
4927*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
4928*0Sstevel@tonic-gate SVOP *kid = (SVOP*)cUNOPo->op_first;
4929*0Sstevel@tonic-gate
4930*0Sstevel@tonic-gate if (!kid) {
4931*0Sstevel@tonic-gate o->op_flags &= ~OPf_KIDS;
4932*0Sstevel@tonic-gate op_null(o);
4933*0Sstevel@tonic-gate }
4934*0Sstevel@tonic-gate else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
4935*0Sstevel@tonic-gate LOGOP *enter;
4936*0Sstevel@tonic-gate
4937*0Sstevel@tonic-gate cUNOPo->op_first = 0;
4938*0Sstevel@tonic-gate op_free(o);
4939*0Sstevel@tonic-gate
4940*0Sstevel@tonic-gate NewOp(1101, enter, 1, LOGOP);
4941*0Sstevel@tonic-gate enter->op_type = OP_ENTERTRY;
4942*0Sstevel@tonic-gate enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
4943*0Sstevel@tonic-gate enter->op_private = 0;
4944*0Sstevel@tonic-gate
4945*0Sstevel@tonic-gate /* establish postfix order */
4946*0Sstevel@tonic-gate enter->op_next = (OP*)enter;
4947*0Sstevel@tonic-gate
4948*0Sstevel@tonic-gate o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4949*0Sstevel@tonic-gate o->op_type = OP_LEAVETRY;
4950*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
4951*0Sstevel@tonic-gate enter->op_other = o;
4952*0Sstevel@tonic-gate return o;
4953*0Sstevel@tonic-gate }
4954*0Sstevel@tonic-gate else
4955*0Sstevel@tonic-gate scalar((OP*)kid);
4956*0Sstevel@tonic-gate }
4957*0Sstevel@tonic-gate else {
4958*0Sstevel@tonic-gate op_free(o);
4959*0Sstevel@tonic-gate o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4960*0Sstevel@tonic-gate }
4961*0Sstevel@tonic-gate o->op_targ = (PADOFFSET)PL_hints;
4962*0Sstevel@tonic-gate return o;
4963*0Sstevel@tonic-gate }
4964*0Sstevel@tonic-gate
4965*0Sstevel@tonic-gate OP *
Perl_ck_exit(pTHX_ OP * o)4966*0Sstevel@tonic-gate Perl_ck_exit(pTHX_ OP *o)
4967*0Sstevel@tonic-gate {
4968*0Sstevel@tonic-gate #ifdef VMS
4969*0Sstevel@tonic-gate HV *table = GvHV(PL_hintgv);
4970*0Sstevel@tonic-gate if (table) {
4971*0Sstevel@tonic-gate SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
4972*0Sstevel@tonic-gate if (svp && *svp && SvTRUE(*svp))
4973*0Sstevel@tonic-gate o->op_private |= OPpEXIT_VMSISH;
4974*0Sstevel@tonic-gate }
4975*0Sstevel@tonic-gate if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
4976*0Sstevel@tonic-gate #endif
4977*0Sstevel@tonic-gate return ck_fun(o);
4978*0Sstevel@tonic-gate }
4979*0Sstevel@tonic-gate
4980*0Sstevel@tonic-gate OP *
Perl_ck_exec(pTHX_ OP * o)4981*0Sstevel@tonic-gate Perl_ck_exec(pTHX_ OP *o)
4982*0Sstevel@tonic-gate {
4983*0Sstevel@tonic-gate OP *kid;
4984*0Sstevel@tonic-gate if (o->op_flags & OPf_STACKED) {
4985*0Sstevel@tonic-gate o = ck_fun(o);
4986*0Sstevel@tonic-gate kid = cUNOPo->op_first->op_sibling;
4987*0Sstevel@tonic-gate if (kid->op_type == OP_RV2GV)
4988*0Sstevel@tonic-gate op_null(kid);
4989*0Sstevel@tonic-gate }
4990*0Sstevel@tonic-gate else
4991*0Sstevel@tonic-gate o = listkids(o);
4992*0Sstevel@tonic-gate return o;
4993*0Sstevel@tonic-gate }
4994*0Sstevel@tonic-gate
4995*0Sstevel@tonic-gate OP *
Perl_ck_exists(pTHX_ OP * o)4996*0Sstevel@tonic-gate Perl_ck_exists(pTHX_ OP *o)
4997*0Sstevel@tonic-gate {
4998*0Sstevel@tonic-gate o = ck_fun(o);
4999*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
5000*0Sstevel@tonic-gate OP *kid = cUNOPo->op_first;
5001*0Sstevel@tonic-gate if (kid->op_type == OP_ENTERSUB) {
5002*0Sstevel@tonic-gate (void) ref(kid, o->op_type);
5003*0Sstevel@tonic-gate if (kid->op_type != OP_RV2CV && !PL_error_count)
5004*0Sstevel@tonic-gate Perl_croak(aTHX_ "%s argument is not a subroutine name",
5005*0Sstevel@tonic-gate OP_DESC(o));
5006*0Sstevel@tonic-gate o->op_private |= OPpEXISTS_SUB;
5007*0Sstevel@tonic-gate }
5008*0Sstevel@tonic-gate else if (kid->op_type == OP_AELEM)
5009*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL;
5010*0Sstevel@tonic-gate else if (kid->op_type != OP_HELEM)
5011*0Sstevel@tonic-gate Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5012*0Sstevel@tonic-gate OP_DESC(o));
5013*0Sstevel@tonic-gate op_null(kid);
5014*0Sstevel@tonic-gate }
5015*0Sstevel@tonic-gate return o;
5016*0Sstevel@tonic-gate }
5017*0Sstevel@tonic-gate
5018*0Sstevel@tonic-gate #if 0
5019*0Sstevel@tonic-gate OP *
5020*0Sstevel@tonic-gate Perl_ck_gvconst(pTHX_ register OP *o)
5021*0Sstevel@tonic-gate {
5022*0Sstevel@tonic-gate o = fold_constants(o);
5023*0Sstevel@tonic-gate if (o->op_type == OP_CONST)
5024*0Sstevel@tonic-gate o->op_type = OP_GV;
5025*0Sstevel@tonic-gate return o;
5026*0Sstevel@tonic-gate }
5027*0Sstevel@tonic-gate #endif
5028*0Sstevel@tonic-gate
5029*0Sstevel@tonic-gate OP *
Perl_ck_rvconst(pTHX_ register OP * o)5030*0Sstevel@tonic-gate Perl_ck_rvconst(pTHX_ register OP *o)
5031*0Sstevel@tonic-gate {
5032*0Sstevel@tonic-gate SVOP *kid = (SVOP*)cUNOPo->op_first;
5033*0Sstevel@tonic-gate
5034*0Sstevel@tonic-gate o->op_private |= (PL_hints & HINT_STRICT_REFS);
5035*0Sstevel@tonic-gate if (kid->op_type == OP_CONST) {
5036*0Sstevel@tonic-gate char *name;
5037*0Sstevel@tonic-gate int iscv;
5038*0Sstevel@tonic-gate GV *gv;
5039*0Sstevel@tonic-gate SV *kidsv = kid->op_sv;
5040*0Sstevel@tonic-gate STRLEN n_a;
5041*0Sstevel@tonic-gate
5042*0Sstevel@tonic-gate /* Is it a constant from cv_const_sv()? */
5043*0Sstevel@tonic-gate if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5044*0Sstevel@tonic-gate SV *rsv = SvRV(kidsv);
5045*0Sstevel@tonic-gate int svtype = SvTYPE(rsv);
5046*0Sstevel@tonic-gate char *badtype = Nullch;
5047*0Sstevel@tonic-gate
5048*0Sstevel@tonic-gate switch (o->op_type) {
5049*0Sstevel@tonic-gate case OP_RV2SV:
5050*0Sstevel@tonic-gate if (svtype > SVt_PVMG)
5051*0Sstevel@tonic-gate badtype = "a SCALAR";
5052*0Sstevel@tonic-gate break;
5053*0Sstevel@tonic-gate case OP_RV2AV:
5054*0Sstevel@tonic-gate if (svtype != SVt_PVAV)
5055*0Sstevel@tonic-gate badtype = "an ARRAY";
5056*0Sstevel@tonic-gate break;
5057*0Sstevel@tonic-gate case OP_RV2HV:
5058*0Sstevel@tonic-gate if (svtype != SVt_PVHV) {
5059*0Sstevel@tonic-gate if (svtype == SVt_PVAV) { /* pseudohash? */
5060*0Sstevel@tonic-gate SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5061*0Sstevel@tonic-gate if (ksv && SvROK(*ksv)
5062*0Sstevel@tonic-gate && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5063*0Sstevel@tonic-gate {
5064*0Sstevel@tonic-gate break;
5065*0Sstevel@tonic-gate }
5066*0Sstevel@tonic-gate }
5067*0Sstevel@tonic-gate badtype = "a HASH";
5068*0Sstevel@tonic-gate }
5069*0Sstevel@tonic-gate break;
5070*0Sstevel@tonic-gate case OP_RV2CV:
5071*0Sstevel@tonic-gate if (svtype != SVt_PVCV)
5072*0Sstevel@tonic-gate badtype = "a CODE";
5073*0Sstevel@tonic-gate break;
5074*0Sstevel@tonic-gate }
5075*0Sstevel@tonic-gate if (badtype)
5076*0Sstevel@tonic-gate Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5077*0Sstevel@tonic-gate return o;
5078*0Sstevel@tonic-gate }
5079*0Sstevel@tonic-gate name = SvPV(kidsv, n_a);
5080*0Sstevel@tonic-gate if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5081*0Sstevel@tonic-gate char *badthing = Nullch;
5082*0Sstevel@tonic-gate switch (o->op_type) {
5083*0Sstevel@tonic-gate case OP_RV2SV:
5084*0Sstevel@tonic-gate badthing = "a SCALAR";
5085*0Sstevel@tonic-gate break;
5086*0Sstevel@tonic-gate case OP_RV2AV:
5087*0Sstevel@tonic-gate badthing = "an ARRAY";
5088*0Sstevel@tonic-gate break;
5089*0Sstevel@tonic-gate case OP_RV2HV:
5090*0Sstevel@tonic-gate badthing = "a HASH";
5091*0Sstevel@tonic-gate break;
5092*0Sstevel@tonic-gate }
5093*0Sstevel@tonic-gate if (badthing)
5094*0Sstevel@tonic-gate Perl_croak(aTHX_
5095*0Sstevel@tonic-gate "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5096*0Sstevel@tonic-gate name, badthing);
5097*0Sstevel@tonic-gate }
5098*0Sstevel@tonic-gate /*
5099*0Sstevel@tonic-gate * This is a little tricky. We only want to add the symbol if we
5100*0Sstevel@tonic-gate * didn't add it in the lexer. Otherwise we get duplicate strict
5101*0Sstevel@tonic-gate * warnings. But if we didn't add it in the lexer, we must at
5102*0Sstevel@tonic-gate * least pretend like we wanted to add it even if it existed before,
5103*0Sstevel@tonic-gate * or we get possible typo warnings. OPpCONST_ENTERED says
5104*0Sstevel@tonic-gate * whether the lexer already added THIS instance of this symbol.
5105*0Sstevel@tonic-gate */
5106*0Sstevel@tonic-gate iscv = (o->op_type == OP_RV2CV) * 2;
5107*0Sstevel@tonic-gate do {
5108*0Sstevel@tonic-gate gv = gv_fetchpv(name,
5109*0Sstevel@tonic-gate iscv | !(kid->op_private & OPpCONST_ENTERED),
5110*0Sstevel@tonic-gate iscv
5111*0Sstevel@tonic-gate ? SVt_PVCV
5112*0Sstevel@tonic-gate : o->op_type == OP_RV2SV
5113*0Sstevel@tonic-gate ? SVt_PV
5114*0Sstevel@tonic-gate : o->op_type == OP_RV2AV
5115*0Sstevel@tonic-gate ? SVt_PVAV
5116*0Sstevel@tonic-gate : o->op_type == OP_RV2HV
5117*0Sstevel@tonic-gate ? SVt_PVHV
5118*0Sstevel@tonic-gate : SVt_PVGV);
5119*0Sstevel@tonic-gate } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5120*0Sstevel@tonic-gate if (gv) {
5121*0Sstevel@tonic-gate kid->op_type = OP_GV;
5122*0Sstevel@tonic-gate SvREFCNT_dec(kid->op_sv);
5123*0Sstevel@tonic-gate #ifdef USE_ITHREADS
5124*0Sstevel@tonic-gate /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5125*0Sstevel@tonic-gate kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5126*0Sstevel@tonic-gate SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5127*0Sstevel@tonic-gate GvIN_PAD_on(gv);
5128*0Sstevel@tonic-gate PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5129*0Sstevel@tonic-gate #else
5130*0Sstevel@tonic-gate kid->op_sv = SvREFCNT_inc(gv);
5131*0Sstevel@tonic-gate #endif
5132*0Sstevel@tonic-gate kid->op_private = 0;
5133*0Sstevel@tonic-gate kid->op_ppaddr = PL_ppaddr[OP_GV];
5134*0Sstevel@tonic-gate }
5135*0Sstevel@tonic-gate }
5136*0Sstevel@tonic-gate return o;
5137*0Sstevel@tonic-gate }
5138*0Sstevel@tonic-gate
5139*0Sstevel@tonic-gate OP *
Perl_ck_ftst(pTHX_ OP * o)5140*0Sstevel@tonic-gate Perl_ck_ftst(pTHX_ OP *o)
5141*0Sstevel@tonic-gate {
5142*0Sstevel@tonic-gate I32 type = o->op_type;
5143*0Sstevel@tonic-gate
5144*0Sstevel@tonic-gate if (o->op_flags & OPf_REF) {
5145*0Sstevel@tonic-gate /* nothing */
5146*0Sstevel@tonic-gate }
5147*0Sstevel@tonic-gate else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5148*0Sstevel@tonic-gate SVOP *kid = (SVOP*)cUNOPo->op_first;
5149*0Sstevel@tonic-gate
5150*0Sstevel@tonic-gate if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5151*0Sstevel@tonic-gate STRLEN n_a;
5152*0Sstevel@tonic-gate OP *newop = newGVOP(type, OPf_REF,
5153*0Sstevel@tonic-gate gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5154*0Sstevel@tonic-gate op_free(o);
5155*0Sstevel@tonic-gate o = newop;
5156*0Sstevel@tonic-gate }
5157*0Sstevel@tonic-gate else {
5158*0Sstevel@tonic-gate if ((PL_hints & HINT_FILETEST_ACCESS) &&
5159*0Sstevel@tonic-gate OP_IS_FILETEST_ACCESS(o))
5160*0Sstevel@tonic-gate o->op_private |= OPpFT_ACCESS;
5161*0Sstevel@tonic-gate }
5162*0Sstevel@tonic-gate }
5163*0Sstevel@tonic-gate else {
5164*0Sstevel@tonic-gate op_free(o);
5165*0Sstevel@tonic-gate if (type == OP_FTTTY)
5166*0Sstevel@tonic-gate o = newGVOP(type, OPf_REF, PL_stdingv);
5167*0Sstevel@tonic-gate else
5168*0Sstevel@tonic-gate o = newUNOP(type, 0, newDEFSVOP());
5169*0Sstevel@tonic-gate }
5170*0Sstevel@tonic-gate return o;
5171*0Sstevel@tonic-gate }
5172*0Sstevel@tonic-gate
5173*0Sstevel@tonic-gate OP *
Perl_ck_fun(pTHX_ OP * o)5174*0Sstevel@tonic-gate Perl_ck_fun(pTHX_ OP *o)
5175*0Sstevel@tonic-gate {
5176*0Sstevel@tonic-gate register OP *kid;
5177*0Sstevel@tonic-gate OP **tokid;
5178*0Sstevel@tonic-gate OP *sibl;
5179*0Sstevel@tonic-gate I32 numargs = 0;
5180*0Sstevel@tonic-gate int type = o->op_type;
5181*0Sstevel@tonic-gate register I32 oa = PL_opargs[type] >> OASHIFT;
5182*0Sstevel@tonic-gate
5183*0Sstevel@tonic-gate if (o->op_flags & OPf_STACKED) {
5184*0Sstevel@tonic-gate if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5185*0Sstevel@tonic-gate oa &= ~OA_OPTIONAL;
5186*0Sstevel@tonic-gate else
5187*0Sstevel@tonic-gate return no_fh_allowed(o);
5188*0Sstevel@tonic-gate }
5189*0Sstevel@tonic-gate
5190*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
5191*0Sstevel@tonic-gate STRLEN n_a;
5192*0Sstevel@tonic-gate tokid = &cLISTOPo->op_first;
5193*0Sstevel@tonic-gate kid = cLISTOPo->op_first;
5194*0Sstevel@tonic-gate if (kid->op_type == OP_PUSHMARK ||
5195*0Sstevel@tonic-gate (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5196*0Sstevel@tonic-gate {
5197*0Sstevel@tonic-gate tokid = &kid->op_sibling;
5198*0Sstevel@tonic-gate kid = kid->op_sibling;
5199*0Sstevel@tonic-gate }
5200*0Sstevel@tonic-gate if (!kid && PL_opargs[type] & OA_DEFGV)
5201*0Sstevel@tonic-gate *tokid = kid = newDEFSVOP();
5202*0Sstevel@tonic-gate
5203*0Sstevel@tonic-gate while (oa && kid) {
5204*0Sstevel@tonic-gate numargs++;
5205*0Sstevel@tonic-gate sibl = kid->op_sibling;
5206*0Sstevel@tonic-gate switch (oa & 7) {
5207*0Sstevel@tonic-gate case OA_SCALAR:
5208*0Sstevel@tonic-gate /* list seen where single (scalar) arg expected? */
5209*0Sstevel@tonic-gate if (numargs == 1 && !(oa >> 4)
5210*0Sstevel@tonic-gate && kid->op_type == OP_LIST && type != OP_SCALAR)
5211*0Sstevel@tonic-gate {
5212*0Sstevel@tonic-gate return too_many_arguments(o,PL_op_desc[type]);
5213*0Sstevel@tonic-gate }
5214*0Sstevel@tonic-gate scalar(kid);
5215*0Sstevel@tonic-gate break;
5216*0Sstevel@tonic-gate case OA_LIST:
5217*0Sstevel@tonic-gate if (oa < 16) {
5218*0Sstevel@tonic-gate kid = 0;
5219*0Sstevel@tonic-gate continue;
5220*0Sstevel@tonic-gate }
5221*0Sstevel@tonic-gate else
5222*0Sstevel@tonic-gate list(kid);
5223*0Sstevel@tonic-gate break;
5224*0Sstevel@tonic-gate case OA_AVREF:
5225*0Sstevel@tonic-gate if ((type == OP_PUSH || type == OP_UNSHIFT)
5226*0Sstevel@tonic-gate && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5227*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5228*0Sstevel@tonic-gate "Useless use of %s with no values",
5229*0Sstevel@tonic-gate PL_op_desc[type]);
5230*0Sstevel@tonic-gate
5231*0Sstevel@tonic-gate if (kid->op_type == OP_CONST &&
5232*0Sstevel@tonic-gate (kid->op_private & OPpCONST_BARE))
5233*0Sstevel@tonic-gate {
5234*0Sstevel@tonic-gate char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5235*0Sstevel@tonic-gate OP *newop = newAVREF(newGVOP(OP_GV, 0,
5236*0Sstevel@tonic-gate gv_fetchpv(name, TRUE, SVt_PVAV) ));
5237*0Sstevel@tonic-gate if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5238*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5239*0Sstevel@tonic-gate "Array @%s missing the @ in argument %"IVdf" of %s()",
5240*0Sstevel@tonic-gate name, (IV)numargs, PL_op_desc[type]);
5241*0Sstevel@tonic-gate op_free(kid);
5242*0Sstevel@tonic-gate kid = newop;
5243*0Sstevel@tonic-gate kid->op_sibling = sibl;
5244*0Sstevel@tonic-gate *tokid = kid;
5245*0Sstevel@tonic-gate }
5246*0Sstevel@tonic-gate else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5247*0Sstevel@tonic-gate bad_type(numargs, "array", PL_op_desc[type], kid);
5248*0Sstevel@tonic-gate mod(kid, type);
5249*0Sstevel@tonic-gate break;
5250*0Sstevel@tonic-gate case OA_HVREF:
5251*0Sstevel@tonic-gate if (kid->op_type == OP_CONST &&
5252*0Sstevel@tonic-gate (kid->op_private & OPpCONST_BARE))
5253*0Sstevel@tonic-gate {
5254*0Sstevel@tonic-gate char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5255*0Sstevel@tonic-gate OP *newop = newHVREF(newGVOP(OP_GV, 0,
5256*0Sstevel@tonic-gate gv_fetchpv(name, TRUE, SVt_PVHV) ));
5257*0Sstevel@tonic-gate if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5258*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5259*0Sstevel@tonic-gate "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5260*0Sstevel@tonic-gate name, (IV)numargs, PL_op_desc[type]);
5261*0Sstevel@tonic-gate op_free(kid);
5262*0Sstevel@tonic-gate kid = newop;
5263*0Sstevel@tonic-gate kid->op_sibling = sibl;
5264*0Sstevel@tonic-gate *tokid = kid;
5265*0Sstevel@tonic-gate }
5266*0Sstevel@tonic-gate else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5267*0Sstevel@tonic-gate bad_type(numargs, "hash", PL_op_desc[type], kid);
5268*0Sstevel@tonic-gate mod(kid, type);
5269*0Sstevel@tonic-gate break;
5270*0Sstevel@tonic-gate case OA_CVREF:
5271*0Sstevel@tonic-gate {
5272*0Sstevel@tonic-gate OP *newop = newUNOP(OP_NULL, 0, kid);
5273*0Sstevel@tonic-gate kid->op_sibling = 0;
5274*0Sstevel@tonic-gate linklist(kid);
5275*0Sstevel@tonic-gate newop->op_next = newop;
5276*0Sstevel@tonic-gate kid = newop;
5277*0Sstevel@tonic-gate kid->op_sibling = sibl;
5278*0Sstevel@tonic-gate *tokid = kid;
5279*0Sstevel@tonic-gate }
5280*0Sstevel@tonic-gate break;
5281*0Sstevel@tonic-gate case OA_FILEREF:
5282*0Sstevel@tonic-gate if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5283*0Sstevel@tonic-gate if (kid->op_type == OP_CONST &&
5284*0Sstevel@tonic-gate (kid->op_private & OPpCONST_BARE))
5285*0Sstevel@tonic-gate {
5286*0Sstevel@tonic-gate OP *newop = newGVOP(OP_GV, 0,
5287*0Sstevel@tonic-gate gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5288*0Sstevel@tonic-gate SVt_PVIO) );
5289*0Sstevel@tonic-gate if (!(o->op_private & 1) && /* if not unop */
5290*0Sstevel@tonic-gate kid == cLISTOPo->op_last)
5291*0Sstevel@tonic-gate cLISTOPo->op_last = newop;
5292*0Sstevel@tonic-gate op_free(kid);
5293*0Sstevel@tonic-gate kid = newop;
5294*0Sstevel@tonic-gate }
5295*0Sstevel@tonic-gate else if (kid->op_type == OP_READLINE) {
5296*0Sstevel@tonic-gate /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5297*0Sstevel@tonic-gate bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5298*0Sstevel@tonic-gate }
5299*0Sstevel@tonic-gate else {
5300*0Sstevel@tonic-gate I32 flags = OPf_SPECIAL;
5301*0Sstevel@tonic-gate I32 priv = 0;
5302*0Sstevel@tonic-gate PADOFFSET targ = 0;
5303*0Sstevel@tonic-gate
5304*0Sstevel@tonic-gate /* is this op a FH constructor? */
5305*0Sstevel@tonic-gate if (is_handle_constructor(o,numargs)) {
5306*0Sstevel@tonic-gate char *name = Nullch;
5307*0Sstevel@tonic-gate STRLEN len = 0;
5308*0Sstevel@tonic-gate
5309*0Sstevel@tonic-gate flags = 0;
5310*0Sstevel@tonic-gate /* Set a flag to tell rv2gv to vivify
5311*0Sstevel@tonic-gate * need to "prove" flag does not mean something
5312*0Sstevel@tonic-gate * else already - NI-S 1999/05/07
5313*0Sstevel@tonic-gate */
5314*0Sstevel@tonic-gate priv = OPpDEREF;
5315*0Sstevel@tonic-gate if (kid->op_type == OP_PADSV) {
5316*0Sstevel@tonic-gate /*XXX DAPM 2002.08.25 tmp assert test */
5317*0Sstevel@tonic-gate /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5318*0Sstevel@tonic-gate /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE));
5319*0Sstevel@tonic-gate
5320*0Sstevel@tonic-gate name = PAD_COMPNAME_PV(kid->op_targ);
5321*0Sstevel@tonic-gate /* SvCUR of a pad namesv can't be trusted
5322*0Sstevel@tonic-gate * (see PL_generation), so calc its length
5323*0Sstevel@tonic-gate * manually */
5324*0Sstevel@tonic-gate if (name)
5325*0Sstevel@tonic-gate len = strlen(name);
5326*0Sstevel@tonic-gate
5327*0Sstevel@tonic-gate }
5328*0Sstevel@tonic-gate else if (kid->op_type == OP_RV2SV
5329*0Sstevel@tonic-gate && kUNOP->op_first->op_type == OP_GV)
5330*0Sstevel@tonic-gate {
5331*0Sstevel@tonic-gate GV *gv = cGVOPx_gv(kUNOP->op_first);
5332*0Sstevel@tonic-gate name = GvNAME(gv);
5333*0Sstevel@tonic-gate len = GvNAMELEN(gv);
5334*0Sstevel@tonic-gate }
5335*0Sstevel@tonic-gate else if (kid->op_type == OP_AELEM
5336*0Sstevel@tonic-gate || kid->op_type == OP_HELEM)
5337*0Sstevel@tonic-gate {
5338*0Sstevel@tonic-gate OP *op;
5339*0Sstevel@tonic-gate
5340*0Sstevel@tonic-gate name = 0;
5341*0Sstevel@tonic-gate if ((op = ((BINOP*)kid)->op_first)) {
5342*0Sstevel@tonic-gate SV *tmpstr = Nullsv;
5343*0Sstevel@tonic-gate char *a =
5344*0Sstevel@tonic-gate kid->op_type == OP_AELEM ?
5345*0Sstevel@tonic-gate "[]" : "{}";
5346*0Sstevel@tonic-gate if (((op->op_type == OP_RV2AV) ||
5347*0Sstevel@tonic-gate (op->op_type == OP_RV2HV)) &&
5348*0Sstevel@tonic-gate (op = ((UNOP*)op)->op_first) &&
5349*0Sstevel@tonic-gate (op->op_type == OP_GV)) {
5350*0Sstevel@tonic-gate /* packagevar $a[] or $h{} */
5351*0Sstevel@tonic-gate GV *gv = cGVOPx_gv(op);
5352*0Sstevel@tonic-gate if (gv)
5353*0Sstevel@tonic-gate tmpstr =
5354*0Sstevel@tonic-gate Perl_newSVpvf(aTHX_
5355*0Sstevel@tonic-gate "%s%c...%c",
5356*0Sstevel@tonic-gate GvNAME(gv),
5357*0Sstevel@tonic-gate a[0], a[1]);
5358*0Sstevel@tonic-gate }
5359*0Sstevel@tonic-gate else if (op->op_type == OP_PADAV
5360*0Sstevel@tonic-gate || op->op_type == OP_PADHV) {
5361*0Sstevel@tonic-gate /* lexicalvar $a[] or $h{} */
5362*0Sstevel@tonic-gate char *padname =
5363*0Sstevel@tonic-gate PAD_COMPNAME_PV(op->op_targ);
5364*0Sstevel@tonic-gate if (padname)
5365*0Sstevel@tonic-gate tmpstr =
5366*0Sstevel@tonic-gate Perl_newSVpvf(aTHX_
5367*0Sstevel@tonic-gate "%s%c...%c",
5368*0Sstevel@tonic-gate padname + 1,
5369*0Sstevel@tonic-gate a[0], a[1]);
5370*0Sstevel@tonic-gate
5371*0Sstevel@tonic-gate }
5372*0Sstevel@tonic-gate if (tmpstr) {
5373*0Sstevel@tonic-gate name = SvPV(tmpstr, len);
5374*0Sstevel@tonic-gate sv_2mortal(tmpstr);
5375*0Sstevel@tonic-gate }
5376*0Sstevel@tonic-gate }
5377*0Sstevel@tonic-gate if (!name) {
5378*0Sstevel@tonic-gate name = "__ANONIO__";
5379*0Sstevel@tonic-gate len = 10;
5380*0Sstevel@tonic-gate }
5381*0Sstevel@tonic-gate mod(kid, type);
5382*0Sstevel@tonic-gate }
5383*0Sstevel@tonic-gate if (name) {
5384*0Sstevel@tonic-gate SV *namesv;
5385*0Sstevel@tonic-gate targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5386*0Sstevel@tonic-gate namesv = PAD_SVl(targ);
5387*0Sstevel@tonic-gate (void)SvUPGRADE(namesv, SVt_PV);
5388*0Sstevel@tonic-gate if (*name != '$')
5389*0Sstevel@tonic-gate sv_setpvn(namesv, "$", 1);
5390*0Sstevel@tonic-gate sv_catpvn(namesv, name, len);
5391*0Sstevel@tonic-gate }
5392*0Sstevel@tonic-gate }
5393*0Sstevel@tonic-gate kid->op_sibling = 0;
5394*0Sstevel@tonic-gate kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5395*0Sstevel@tonic-gate kid->op_targ = targ;
5396*0Sstevel@tonic-gate kid->op_private |= priv;
5397*0Sstevel@tonic-gate }
5398*0Sstevel@tonic-gate kid->op_sibling = sibl;
5399*0Sstevel@tonic-gate *tokid = kid;
5400*0Sstevel@tonic-gate }
5401*0Sstevel@tonic-gate scalar(kid);
5402*0Sstevel@tonic-gate break;
5403*0Sstevel@tonic-gate case OA_SCALARREF:
5404*0Sstevel@tonic-gate mod(scalar(kid), type);
5405*0Sstevel@tonic-gate break;
5406*0Sstevel@tonic-gate }
5407*0Sstevel@tonic-gate oa >>= 4;
5408*0Sstevel@tonic-gate tokid = &kid->op_sibling;
5409*0Sstevel@tonic-gate kid = kid->op_sibling;
5410*0Sstevel@tonic-gate }
5411*0Sstevel@tonic-gate o->op_private |= numargs;
5412*0Sstevel@tonic-gate if (kid)
5413*0Sstevel@tonic-gate return too_many_arguments(o,OP_DESC(o));
5414*0Sstevel@tonic-gate listkids(o);
5415*0Sstevel@tonic-gate }
5416*0Sstevel@tonic-gate else if (PL_opargs[type] & OA_DEFGV) {
5417*0Sstevel@tonic-gate op_free(o);
5418*0Sstevel@tonic-gate return newUNOP(type, 0, newDEFSVOP());
5419*0Sstevel@tonic-gate }
5420*0Sstevel@tonic-gate
5421*0Sstevel@tonic-gate if (oa) {
5422*0Sstevel@tonic-gate while (oa & OA_OPTIONAL)
5423*0Sstevel@tonic-gate oa >>= 4;
5424*0Sstevel@tonic-gate if (oa && oa != OA_LIST)
5425*0Sstevel@tonic-gate return too_few_arguments(o,OP_DESC(o));
5426*0Sstevel@tonic-gate }
5427*0Sstevel@tonic-gate return o;
5428*0Sstevel@tonic-gate }
5429*0Sstevel@tonic-gate
5430*0Sstevel@tonic-gate OP *
Perl_ck_glob(pTHX_ OP * o)5431*0Sstevel@tonic-gate Perl_ck_glob(pTHX_ OP *o)
5432*0Sstevel@tonic-gate {
5433*0Sstevel@tonic-gate GV *gv;
5434*0Sstevel@tonic-gate
5435*0Sstevel@tonic-gate o = ck_fun(o);
5436*0Sstevel@tonic-gate if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5437*0Sstevel@tonic-gate append_elem(OP_GLOB, o, newDEFSVOP());
5438*0Sstevel@tonic-gate
5439*0Sstevel@tonic-gate if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5440*0Sstevel@tonic-gate && GvCVu(gv) && GvIMPORTED_CV(gv)))
5441*0Sstevel@tonic-gate {
5442*0Sstevel@tonic-gate gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5443*0Sstevel@tonic-gate }
5444*0Sstevel@tonic-gate
5445*0Sstevel@tonic-gate #if !defined(PERL_EXTERNAL_GLOB)
5446*0Sstevel@tonic-gate /* XXX this can be tightened up and made more failsafe. */
5447*0Sstevel@tonic-gate if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5448*0Sstevel@tonic-gate GV *glob_gv;
5449*0Sstevel@tonic-gate ENTER;
5450*0Sstevel@tonic-gate Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5451*0Sstevel@tonic-gate newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5452*0Sstevel@tonic-gate gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5453*0Sstevel@tonic-gate glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5454*0Sstevel@tonic-gate GvCV(gv) = GvCV(glob_gv);
5455*0Sstevel@tonic-gate SvREFCNT_inc((SV*)GvCV(gv));
5456*0Sstevel@tonic-gate GvIMPORTED_CV_on(gv);
5457*0Sstevel@tonic-gate LEAVE;
5458*0Sstevel@tonic-gate }
5459*0Sstevel@tonic-gate #endif /* PERL_EXTERNAL_GLOB */
5460*0Sstevel@tonic-gate
5461*0Sstevel@tonic-gate if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5462*0Sstevel@tonic-gate append_elem(OP_GLOB, o,
5463*0Sstevel@tonic-gate newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5464*0Sstevel@tonic-gate o->op_type = OP_LIST;
5465*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_LIST];
5466*0Sstevel@tonic-gate cLISTOPo->op_first->op_type = OP_PUSHMARK;
5467*0Sstevel@tonic-gate cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5468*0Sstevel@tonic-gate cLISTOPo->op_first->op_targ = 0;
5469*0Sstevel@tonic-gate o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5470*0Sstevel@tonic-gate append_elem(OP_LIST, o,
5471*0Sstevel@tonic-gate scalar(newUNOP(OP_RV2CV, 0,
5472*0Sstevel@tonic-gate newGVOP(OP_GV, 0, gv)))));
5473*0Sstevel@tonic-gate o = newUNOP(OP_NULL, 0, ck_subr(o));
5474*0Sstevel@tonic-gate o->op_targ = OP_GLOB; /* hint at what it used to be */
5475*0Sstevel@tonic-gate return o;
5476*0Sstevel@tonic-gate }
5477*0Sstevel@tonic-gate gv = newGVgen("main");
5478*0Sstevel@tonic-gate gv_IOadd(gv);
5479*0Sstevel@tonic-gate append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5480*0Sstevel@tonic-gate scalarkids(o);
5481*0Sstevel@tonic-gate return o;
5482*0Sstevel@tonic-gate }
5483*0Sstevel@tonic-gate
5484*0Sstevel@tonic-gate OP *
Perl_ck_grep(pTHX_ OP * o)5485*0Sstevel@tonic-gate Perl_ck_grep(pTHX_ OP *o)
5486*0Sstevel@tonic-gate {
5487*0Sstevel@tonic-gate LOGOP *gwop;
5488*0Sstevel@tonic-gate OP *kid;
5489*0Sstevel@tonic-gate OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5490*0Sstevel@tonic-gate
5491*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5492*0Sstevel@tonic-gate NewOp(1101, gwop, 1, LOGOP);
5493*0Sstevel@tonic-gate
5494*0Sstevel@tonic-gate if (o->op_flags & OPf_STACKED) {
5495*0Sstevel@tonic-gate OP* k;
5496*0Sstevel@tonic-gate o = ck_sort(o);
5497*0Sstevel@tonic-gate kid = cLISTOPo->op_first->op_sibling;
5498*0Sstevel@tonic-gate for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5499*0Sstevel@tonic-gate kid = k;
5500*0Sstevel@tonic-gate }
5501*0Sstevel@tonic-gate kid->op_next = (OP*)gwop;
5502*0Sstevel@tonic-gate o->op_flags &= ~OPf_STACKED;
5503*0Sstevel@tonic-gate }
5504*0Sstevel@tonic-gate kid = cLISTOPo->op_first->op_sibling;
5505*0Sstevel@tonic-gate if (type == OP_MAPWHILE)
5506*0Sstevel@tonic-gate list(kid);
5507*0Sstevel@tonic-gate else
5508*0Sstevel@tonic-gate scalar(kid);
5509*0Sstevel@tonic-gate o = ck_fun(o);
5510*0Sstevel@tonic-gate if (PL_error_count)
5511*0Sstevel@tonic-gate return o;
5512*0Sstevel@tonic-gate kid = cLISTOPo->op_first->op_sibling;
5513*0Sstevel@tonic-gate if (kid->op_type != OP_NULL)
5514*0Sstevel@tonic-gate Perl_croak(aTHX_ "panic: ck_grep");
5515*0Sstevel@tonic-gate kid = kUNOP->op_first;
5516*0Sstevel@tonic-gate
5517*0Sstevel@tonic-gate gwop->op_type = type;
5518*0Sstevel@tonic-gate gwop->op_ppaddr = PL_ppaddr[type];
5519*0Sstevel@tonic-gate gwop->op_first = listkids(o);
5520*0Sstevel@tonic-gate gwop->op_flags |= OPf_KIDS;
5521*0Sstevel@tonic-gate gwop->op_private = 1;
5522*0Sstevel@tonic-gate gwop->op_other = LINKLIST(kid);
5523*0Sstevel@tonic-gate gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5524*0Sstevel@tonic-gate kid->op_next = (OP*)gwop;
5525*0Sstevel@tonic-gate
5526*0Sstevel@tonic-gate kid = cLISTOPo->op_first->op_sibling;
5527*0Sstevel@tonic-gate if (!kid || !kid->op_sibling)
5528*0Sstevel@tonic-gate return too_few_arguments(o,OP_DESC(o));
5529*0Sstevel@tonic-gate for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5530*0Sstevel@tonic-gate mod(kid, OP_GREPSTART);
5531*0Sstevel@tonic-gate
5532*0Sstevel@tonic-gate return (OP*)gwop;
5533*0Sstevel@tonic-gate }
5534*0Sstevel@tonic-gate
5535*0Sstevel@tonic-gate OP *
Perl_ck_index(pTHX_ OP * o)5536*0Sstevel@tonic-gate Perl_ck_index(pTHX_ OP *o)
5537*0Sstevel@tonic-gate {
5538*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
5539*0Sstevel@tonic-gate OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5540*0Sstevel@tonic-gate if (kid)
5541*0Sstevel@tonic-gate kid = kid->op_sibling; /* get past "big" */
5542*0Sstevel@tonic-gate if (kid && kid->op_type == OP_CONST)
5543*0Sstevel@tonic-gate fbm_compile(((SVOP*)kid)->op_sv, 0);
5544*0Sstevel@tonic-gate }
5545*0Sstevel@tonic-gate return ck_fun(o);
5546*0Sstevel@tonic-gate }
5547*0Sstevel@tonic-gate
5548*0Sstevel@tonic-gate OP *
Perl_ck_lengthconst(pTHX_ OP * o)5549*0Sstevel@tonic-gate Perl_ck_lengthconst(pTHX_ OP *o)
5550*0Sstevel@tonic-gate {
5551*0Sstevel@tonic-gate /* XXX length optimization goes here */
5552*0Sstevel@tonic-gate return ck_fun(o);
5553*0Sstevel@tonic-gate }
5554*0Sstevel@tonic-gate
5555*0Sstevel@tonic-gate OP *
Perl_ck_lfun(pTHX_ OP * o)5556*0Sstevel@tonic-gate Perl_ck_lfun(pTHX_ OP *o)
5557*0Sstevel@tonic-gate {
5558*0Sstevel@tonic-gate OPCODE type = o->op_type;
5559*0Sstevel@tonic-gate return modkids(ck_fun(o), type);
5560*0Sstevel@tonic-gate }
5561*0Sstevel@tonic-gate
5562*0Sstevel@tonic-gate OP *
Perl_ck_defined(pTHX_ OP * o)5563*0Sstevel@tonic-gate Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5564*0Sstevel@tonic-gate {
5565*0Sstevel@tonic-gate if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5566*0Sstevel@tonic-gate switch (cUNOPo->op_first->op_type) {
5567*0Sstevel@tonic-gate case OP_RV2AV:
5568*0Sstevel@tonic-gate /* This is needed for
5569*0Sstevel@tonic-gate if (defined %stash::)
5570*0Sstevel@tonic-gate to work. Do not break Tk.
5571*0Sstevel@tonic-gate */
5572*0Sstevel@tonic-gate break; /* Globals via GV can be undef */
5573*0Sstevel@tonic-gate case OP_PADAV:
5574*0Sstevel@tonic-gate case OP_AASSIGN: /* Is this a good idea? */
5575*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5576*0Sstevel@tonic-gate "defined(@array) is deprecated");
5577*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5578*0Sstevel@tonic-gate "\t(Maybe you should just omit the defined()?)\n");
5579*0Sstevel@tonic-gate break;
5580*0Sstevel@tonic-gate case OP_RV2HV:
5581*0Sstevel@tonic-gate /* This is needed for
5582*0Sstevel@tonic-gate if (defined %stash::)
5583*0Sstevel@tonic-gate to work. Do not break Tk.
5584*0Sstevel@tonic-gate */
5585*0Sstevel@tonic-gate break; /* Globals via GV can be undef */
5586*0Sstevel@tonic-gate case OP_PADHV:
5587*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5588*0Sstevel@tonic-gate "defined(%%hash) is deprecated");
5589*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5590*0Sstevel@tonic-gate "\t(Maybe you should just omit the defined()?)\n");
5591*0Sstevel@tonic-gate break;
5592*0Sstevel@tonic-gate default:
5593*0Sstevel@tonic-gate /* no warning */
5594*0Sstevel@tonic-gate break;
5595*0Sstevel@tonic-gate }
5596*0Sstevel@tonic-gate }
5597*0Sstevel@tonic-gate return ck_rfun(o);
5598*0Sstevel@tonic-gate }
5599*0Sstevel@tonic-gate
5600*0Sstevel@tonic-gate OP *
Perl_ck_rfun(pTHX_ OP * o)5601*0Sstevel@tonic-gate Perl_ck_rfun(pTHX_ OP *o)
5602*0Sstevel@tonic-gate {
5603*0Sstevel@tonic-gate OPCODE type = o->op_type;
5604*0Sstevel@tonic-gate return refkids(ck_fun(o), type);
5605*0Sstevel@tonic-gate }
5606*0Sstevel@tonic-gate
5607*0Sstevel@tonic-gate OP *
Perl_ck_listiob(pTHX_ OP * o)5608*0Sstevel@tonic-gate Perl_ck_listiob(pTHX_ OP *o)
5609*0Sstevel@tonic-gate {
5610*0Sstevel@tonic-gate register OP *kid;
5611*0Sstevel@tonic-gate
5612*0Sstevel@tonic-gate kid = cLISTOPo->op_first;
5613*0Sstevel@tonic-gate if (!kid) {
5614*0Sstevel@tonic-gate o = force_list(o);
5615*0Sstevel@tonic-gate kid = cLISTOPo->op_first;
5616*0Sstevel@tonic-gate }
5617*0Sstevel@tonic-gate if (kid->op_type == OP_PUSHMARK)
5618*0Sstevel@tonic-gate kid = kid->op_sibling;
5619*0Sstevel@tonic-gate if (kid && o->op_flags & OPf_STACKED)
5620*0Sstevel@tonic-gate kid = kid->op_sibling;
5621*0Sstevel@tonic-gate else if (kid && !kid->op_sibling) { /* print HANDLE; */
5622*0Sstevel@tonic-gate if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5623*0Sstevel@tonic-gate o->op_flags |= OPf_STACKED; /* make it a filehandle */
5624*0Sstevel@tonic-gate kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5625*0Sstevel@tonic-gate cLISTOPo->op_first->op_sibling = kid;
5626*0Sstevel@tonic-gate cLISTOPo->op_last = kid;
5627*0Sstevel@tonic-gate kid = kid->op_sibling;
5628*0Sstevel@tonic-gate }
5629*0Sstevel@tonic-gate }
5630*0Sstevel@tonic-gate
5631*0Sstevel@tonic-gate if (!kid)
5632*0Sstevel@tonic-gate append_elem(o->op_type, o, newDEFSVOP());
5633*0Sstevel@tonic-gate
5634*0Sstevel@tonic-gate return listkids(o);
5635*0Sstevel@tonic-gate }
5636*0Sstevel@tonic-gate
5637*0Sstevel@tonic-gate OP *
Perl_ck_sassign(pTHX_ OP * o)5638*0Sstevel@tonic-gate Perl_ck_sassign(pTHX_ OP *o)
5639*0Sstevel@tonic-gate {
5640*0Sstevel@tonic-gate OP *kid = cLISTOPo->op_first;
5641*0Sstevel@tonic-gate /* has a disposable target? */
5642*0Sstevel@tonic-gate if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5643*0Sstevel@tonic-gate && !(kid->op_flags & OPf_STACKED)
5644*0Sstevel@tonic-gate /* Cannot steal the second time! */
5645*0Sstevel@tonic-gate && !(kid->op_private & OPpTARGET_MY))
5646*0Sstevel@tonic-gate {
5647*0Sstevel@tonic-gate OP *kkid = kid->op_sibling;
5648*0Sstevel@tonic-gate
5649*0Sstevel@tonic-gate /* Can just relocate the target. */
5650*0Sstevel@tonic-gate if (kkid && kkid->op_type == OP_PADSV
5651*0Sstevel@tonic-gate && !(kkid->op_private & OPpLVAL_INTRO))
5652*0Sstevel@tonic-gate {
5653*0Sstevel@tonic-gate kid->op_targ = kkid->op_targ;
5654*0Sstevel@tonic-gate kkid->op_targ = 0;
5655*0Sstevel@tonic-gate /* Now we do not need PADSV and SASSIGN. */
5656*0Sstevel@tonic-gate kid->op_sibling = o->op_sibling; /* NULL */
5657*0Sstevel@tonic-gate cLISTOPo->op_first = NULL;
5658*0Sstevel@tonic-gate op_free(o);
5659*0Sstevel@tonic-gate op_free(kkid);
5660*0Sstevel@tonic-gate kid->op_private |= OPpTARGET_MY; /* Used for context settings */
5661*0Sstevel@tonic-gate return kid;
5662*0Sstevel@tonic-gate }
5663*0Sstevel@tonic-gate }
5664*0Sstevel@tonic-gate /* optimise C<my $x = undef> to C<my $x> */
5665*0Sstevel@tonic-gate if (kid->op_type == OP_UNDEF) {
5666*0Sstevel@tonic-gate OP *kkid = kid->op_sibling;
5667*0Sstevel@tonic-gate if (kkid && kkid->op_type == OP_PADSV
5668*0Sstevel@tonic-gate && (kkid->op_private & OPpLVAL_INTRO))
5669*0Sstevel@tonic-gate {
5670*0Sstevel@tonic-gate cLISTOPo->op_first = NULL;
5671*0Sstevel@tonic-gate kid->op_sibling = NULL;
5672*0Sstevel@tonic-gate op_free(o);
5673*0Sstevel@tonic-gate op_free(kid);
5674*0Sstevel@tonic-gate return kkid;
5675*0Sstevel@tonic-gate }
5676*0Sstevel@tonic-gate }
5677*0Sstevel@tonic-gate return o;
5678*0Sstevel@tonic-gate }
5679*0Sstevel@tonic-gate
5680*0Sstevel@tonic-gate OP *
Perl_ck_match(pTHX_ OP * o)5681*0Sstevel@tonic-gate Perl_ck_match(pTHX_ OP *o)
5682*0Sstevel@tonic-gate {
5683*0Sstevel@tonic-gate o->op_private |= OPpRUNTIME;
5684*0Sstevel@tonic-gate return o;
5685*0Sstevel@tonic-gate }
5686*0Sstevel@tonic-gate
5687*0Sstevel@tonic-gate OP *
Perl_ck_method(pTHX_ OP * o)5688*0Sstevel@tonic-gate Perl_ck_method(pTHX_ OP *o)
5689*0Sstevel@tonic-gate {
5690*0Sstevel@tonic-gate OP *kid = cUNOPo->op_first;
5691*0Sstevel@tonic-gate if (kid->op_type == OP_CONST) {
5692*0Sstevel@tonic-gate SV* sv = kSVOP->op_sv;
5693*0Sstevel@tonic-gate if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
5694*0Sstevel@tonic-gate OP *cmop;
5695*0Sstevel@tonic-gate if (!SvREADONLY(sv) || !SvFAKE(sv)) {
5696*0Sstevel@tonic-gate sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
5697*0Sstevel@tonic-gate }
5698*0Sstevel@tonic-gate else {
5699*0Sstevel@tonic-gate kSVOP->op_sv = Nullsv;
5700*0Sstevel@tonic-gate }
5701*0Sstevel@tonic-gate cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
5702*0Sstevel@tonic-gate op_free(o);
5703*0Sstevel@tonic-gate return cmop;
5704*0Sstevel@tonic-gate }
5705*0Sstevel@tonic-gate }
5706*0Sstevel@tonic-gate return o;
5707*0Sstevel@tonic-gate }
5708*0Sstevel@tonic-gate
5709*0Sstevel@tonic-gate OP *
Perl_ck_null(pTHX_ OP * o)5710*0Sstevel@tonic-gate Perl_ck_null(pTHX_ OP *o)
5711*0Sstevel@tonic-gate {
5712*0Sstevel@tonic-gate return o;
5713*0Sstevel@tonic-gate }
5714*0Sstevel@tonic-gate
5715*0Sstevel@tonic-gate OP *
Perl_ck_open(pTHX_ OP * o)5716*0Sstevel@tonic-gate Perl_ck_open(pTHX_ OP *o)
5717*0Sstevel@tonic-gate {
5718*0Sstevel@tonic-gate HV *table = GvHV(PL_hintgv);
5719*0Sstevel@tonic-gate if (table) {
5720*0Sstevel@tonic-gate SV **svp;
5721*0Sstevel@tonic-gate I32 mode;
5722*0Sstevel@tonic-gate svp = hv_fetch(table, "open_IN", 7, FALSE);
5723*0Sstevel@tonic-gate if (svp && *svp) {
5724*0Sstevel@tonic-gate mode = mode_from_discipline(*svp);
5725*0Sstevel@tonic-gate if (mode & O_BINARY)
5726*0Sstevel@tonic-gate o->op_private |= OPpOPEN_IN_RAW;
5727*0Sstevel@tonic-gate else if (mode & O_TEXT)
5728*0Sstevel@tonic-gate o->op_private |= OPpOPEN_IN_CRLF;
5729*0Sstevel@tonic-gate }
5730*0Sstevel@tonic-gate
5731*0Sstevel@tonic-gate svp = hv_fetch(table, "open_OUT", 8, FALSE);
5732*0Sstevel@tonic-gate if (svp && *svp) {
5733*0Sstevel@tonic-gate mode = mode_from_discipline(*svp);
5734*0Sstevel@tonic-gate if (mode & O_BINARY)
5735*0Sstevel@tonic-gate o->op_private |= OPpOPEN_OUT_RAW;
5736*0Sstevel@tonic-gate else if (mode & O_TEXT)
5737*0Sstevel@tonic-gate o->op_private |= OPpOPEN_OUT_CRLF;
5738*0Sstevel@tonic-gate }
5739*0Sstevel@tonic-gate }
5740*0Sstevel@tonic-gate if (o->op_type == OP_BACKTICK)
5741*0Sstevel@tonic-gate return o;
5742*0Sstevel@tonic-gate {
5743*0Sstevel@tonic-gate /* In case of three-arg dup open remove strictness
5744*0Sstevel@tonic-gate * from the last arg if it is a bareword. */
5745*0Sstevel@tonic-gate OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
5746*0Sstevel@tonic-gate OP *last = cLISTOPx(o)->op_last; /* The bareword. */
5747*0Sstevel@tonic-gate OP *oa;
5748*0Sstevel@tonic-gate char *mode;
5749*0Sstevel@tonic-gate
5750*0Sstevel@tonic-gate if ((last->op_type == OP_CONST) && /* The bareword. */
5751*0Sstevel@tonic-gate (last->op_private & OPpCONST_BARE) &&
5752*0Sstevel@tonic-gate (last->op_private & OPpCONST_STRICT) &&
5753*0Sstevel@tonic-gate (oa = first->op_sibling) && /* The fh. */
5754*0Sstevel@tonic-gate (oa = oa->op_sibling) && /* The mode. */
5755*0Sstevel@tonic-gate SvPOK(((SVOP*)oa)->op_sv) &&
5756*0Sstevel@tonic-gate (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
5757*0Sstevel@tonic-gate mode[0] == '>' && mode[1] == '&' && /* A dup open. */
5758*0Sstevel@tonic-gate (last == oa->op_sibling)) /* The bareword. */
5759*0Sstevel@tonic-gate last->op_private &= ~OPpCONST_STRICT;
5760*0Sstevel@tonic-gate }
5761*0Sstevel@tonic-gate return ck_fun(o);
5762*0Sstevel@tonic-gate }
5763*0Sstevel@tonic-gate
5764*0Sstevel@tonic-gate OP *
Perl_ck_repeat(pTHX_ OP * o)5765*0Sstevel@tonic-gate Perl_ck_repeat(pTHX_ OP *o)
5766*0Sstevel@tonic-gate {
5767*0Sstevel@tonic-gate if (cBINOPo->op_first->op_flags & OPf_PARENS) {
5768*0Sstevel@tonic-gate o->op_private |= OPpREPEAT_DOLIST;
5769*0Sstevel@tonic-gate cBINOPo->op_first = force_list(cBINOPo->op_first);
5770*0Sstevel@tonic-gate }
5771*0Sstevel@tonic-gate else
5772*0Sstevel@tonic-gate scalar(o);
5773*0Sstevel@tonic-gate return o;
5774*0Sstevel@tonic-gate }
5775*0Sstevel@tonic-gate
5776*0Sstevel@tonic-gate OP *
Perl_ck_require(pTHX_ OP * o)5777*0Sstevel@tonic-gate Perl_ck_require(pTHX_ OP *o)
5778*0Sstevel@tonic-gate {
5779*0Sstevel@tonic-gate GV* gv;
5780*0Sstevel@tonic-gate
5781*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
5782*0Sstevel@tonic-gate SVOP *kid = (SVOP*)cUNOPo->op_first;
5783*0Sstevel@tonic-gate
5784*0Sstevel@tonic-gate if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5785*0Sstevel@tonic-gate char *s;
5786*0Sstevel@tonic-gate for (s = SvPVX(kid->op_sv); *s; s++) {
5787*0Sstevel@tonic-gate if (*s == ':' && s[1] == ':') {
5788*0Sstevel@tonic-gate *s = '/';
5789*0Sstevel@tonic-gate Move(s+2, s+1, strlen(s+2)+1, char);
5790*0Sstevel@tonic-gate --SvCUR(kid->op_sv);
5791*0Sstevel@tonic-gate }
5792*0Sstevel@tonic-gate }
5793*0Sstevel@tonic-gate if (SvREADONLY(kid->op_sv)) {
5794*0Sstevel@tonic-gate SvREADONLY_off(kid->op_sv);
5795*0Sstevel@tonic-gate sv_catpvn(kid->op_sv, ".pm", 3);
5796*0Sstevel@tonic-gate SvREADONLY_on(kid->op_sv);
5797*0Sstevel@tonic-gate }
5798*0Sstevel@tonic-gate else
5799*0Sstevel@tonic-gate sv_catpvn(kid->op_sv, ".pm", 3);
5800*0Sstevel@tonic-gate }
5801*0Sstevel@tonic-gate }
5802*0Sstevel@tonic-gate
5803*0Sstevel@tonic-gate /* handle override, if any */
5804*0Sstevel@tonic-gate gv = gv_fetchpv("require", FALSE, SVt_PVCV);
5805*0Sstevel@tonic-gate if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
5806*0Sstevel@tonic-gate gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
5807*0Sstevel@tonic-gate
5808*0Sstevel@tonic-gate if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5809*0Sstevel@tonic-gate OP *kid = cUNOPo->op_first;
5810*0Sstevel@tonic-gate cUNOPo->op_first = 0;
5811*0Sstevel@tonic-gate op_free(o);
5812*0Sstevel@tonic-gate return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
5813*0Sstevel@tonic-gate append_elem(OP_LIST, kid,
5814*0Sstevel@tonic-gate scalar(newUNOP(OP_RV2CV, 0,
5815*0Sstevel@tonic-gate newGVOP(OP_GV, 0,
5816*0Sstevel@tonic-gate gv))))));
5817*0Sstevel@tonic-gate }
5818*0Sstevel@tonic-gate
5819*0Sstevel@tonic-gate return ck_fun(o);
5820*0Sstevel@tonic-gate }
5821*0Sstevel@tonic-gate
5822*0Sstevel@tonic-gate OP *
Perl_ck_return(pTHX_ OP * o)5823*0Sstevel@tonic-gate Perl_ck_return(pTHX_ OP *o)
5824*0Sstevel@tonic-gate {
5825*0Sstevel@tonic-gate OP *kid;
5826*0Sstevel@tonic-gate if (CvLVALUE(PL_compcv)) {
5827*0Sstevel@tonic-gate for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
5828*0Sstevel@tonic-gate mod(kid, OP_LEAVESUBLV);
5829*0Sstevel@tonic-gate }
5830*0Sstevel@tonic-gate return o;
5831*0Sstevel@tonic-gate }
5832*0Sstevel@tonic-gate
5833*0Sstevel@tonic-gate #if 0
5834*0Sstevel@tonic-gate OP *
5835*0Sstevel@tonic-gate Perl_ck_retarget(pTHX_ OP *o)
5836*0Sstevel@tonic-gate {
5837*0Sstevel@tonic-gate Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5838*0Sstevel@tonic-gate /* STUB */
5839*0Sstevel@tonic-gate return o;
5840*0Sstevel@tonic-gate }
5841*0Sstevel@tonic-gate #endif
5842*0Sstevel@tonic-gate
5843*0Sstevel@tonic-gate OP *
Perl_ck_select(pTHX_ OP * o)5844*0Sstevel@tonic-gate Perl_ck_select(pTHX_ OP *o)
5845*0Sstevel@tonic-gate {
5846*0Sstevel@tonic-gate OP* kid;
5847*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
5848*0Sstevel@tonic-gate kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5849*0Sstevel@tonic-gate if (kid && kid->op_sibling) {
5850*0Sstevel@tonic-gate o->op_type = OP_SSELECT;
5851*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_SSELECT];
5852*0Sstevel@tonic-gate o = ck_fun(o);
5853*0Sstevel@tonic-gate return fold_constants(o);
5854*0Sstevel@tonic-gate }
5855*0Sstevel@tonic-gate }
5856*0Sstevel@tonic-gate o = ck_fun(o);
5857*0Sstevel@tonic-gate kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5858*0Sstevel@tonic-gate if (kid && kid->op_type == OP_RV2GV)
5859*0Sstevel@tonic-gate kid->op_private &= ~HINT_STRICT_REFS;
5860*0Sstevel@tonic-gate return o;
5861*0Sstevel@tonic-gate }
5862*0Sstevel@tonic-gate
5863*0Sstevel@tonic-gate OP *
Perl_ck_shift(pTHX_ OP * o)5864*0Sstevel@tonic-gate Perl_ck_shift(pTHX_ OP *o)
5865*0Sstevel@tonic-gate {
5866*0Sstevel@tonic-gate I32 type = o->op_type;
5867*0Sstevel@tonic-gate
5868*0Sstevel@tonic-gate if (!(o->op_flags & OPf_KIDS)) {
5869*0Sstevel@tonic-gate OP *argop;
5870*0Sstevel@tonic-gate
5871*0Sstevel@tonic-gate op_free(o);
5872*0Sstevel@tonic-gate #ifdef USE_5005THREADS
5873*0Sstevel@tonic-gate if (!CvUNIQUE(PL_compcv)) {
5874*0Sstevel@tonic-gate argop = newOP(OP_PADAV, OPf_REF);
5875*0Sstevel@tonic-gate argop->op_targ = 0; /* PAD_SV(0) is @_ */
5876*0Sstevel@tonic-gate }
5877*0Sstevel@tonic-gate else {
5878*0Sstevel@tonic-gate argop = newUNOP(OP_RV2AV, 0,
5879*0Sstevel@tonic-gate scalar(newGVOP(OP_GV, 0,
5880*0Sstevel@tonic-gate gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
5881*0Sstevel@tonic-gate }
5882*0Sstevel@tonic-gate #else
5883*0Sstevel@tonic-gate argop = newUNOP(OP_RV2AV, 0,
5884*0Sstevel@tonic-gate scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
5885*0Sstevel@tonic-gate #endif /* USE_5005THREADS */
5886*0Sstevel@tonic-gate return newUNOP(type, 0, scalar(argop));
5887*0Sstevel@tonic-gate }
5888*0Sstevel@tonic-gate return scalar(modkids(ck_fun(o), type));
5889*0Sstevel@tonic-gate }
5890*0Sstevel@tonic-gate
5891*0Sstevel@tonic-gate OP *
Perl_ck_sort(pTHX_ OP * o)5892*0Sstevel@tonic-gate Perl_ck_sort(pTHX_ OP *o)
5893*0Sstevel@tonic-gate {
5894*0Sstevel@tonic-gate OP *firstkid;
5895*0Sstevel@tonic-gate
5896*0Sstevel@tonic-gate if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
5897*0Sstevel@tonic-gate simplify_sort(o);
5898*0Sstevel@tonic-gate firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5899*0Sstevel@tonic-gate if (o->op_flags & OPf_STACKED) { /* may have been cleared */
5900*0Sstevel@tonic-gate OP *k = NULL;
5901*0Sstevel@tonic-gate OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
5902*0Sstevel@tonic-gate
5903*0Sstevel@tonic-gate if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
5904*0Sstevel@tonic-gate linklist(kid);
5905*0Sstevel@tonic-gate if (kid->op_type == OP_SCOPE) {
5906*0Sstevel@tonic-gate k = kid->op_next;
5907*0Sstevel@tonic-gate kid->op_next = 0;
5908*0Sstevel@tonic-gate }
5909*0Sstevel@tonic-gate else if (kid->op_type == OP_LEAVE) {
5910*0Sstevel@tonic-gate if (o->op_type == OP_SORT) {
5911*0Sstevel@tonic-gate op_null(kid); /* wipe out leave */
5912*0Sstevel@tonic-gate kid->op_next = kid;
5913*0Sstevel@tonic-gate
5914*0Sstevel@tonic-gate for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
5915*0Sstevel@tonic-gate if (k->op_next == kid)
5916*0Sstevel@tonic-gate k->op_next = 0;
5917*0Sstevel@tonic-gate /* don't descend into loops */
5918*0Sstevel@tonic-gate else if (k->op_type == OP_ENTERLOOP
5919*0Sstevel@tonic-gate || k->op_type == OP_ENTERITER)
5920*0Sstevel@tonic-gate {
5921*0Sstevel@tonic-gate k = cLOOPx(k)->op_lastop;
5922*0Sstevel@tonic-gate }
5923*0Sstevel@tonic-gate }
5924*0Sstevel@tonic-gate }
5925*0Sstevel@tonic-gate else
5926*0Sstevel@tonic-gate kid->op_next = 0; /* just disconnect the leave */
5927*0Sstevel@tonic-gate k = kLISTOP->op_first;
5928*0Sstevel@tonic-gate }
5929*0Sstevel@tonic-gate CALL_PEEP(k);
5930*0Sstevel@tonic-gate
5931*0Sstevel@tonic-gate kid = firstkid;
5932*0Sstevel@tonic-gate if (o->op_type == OP_SORT) {
5933*0Sstevel@tonic-gate /* provide scalar context for comparison function/block */
5934*0Sstevel@tonic-gate kid = scalar(kid);
5935*0Sstevel@tonic-gate kid->op_next = kid;
5936*0Sstevel@tonic-gate }
5937*0Sstevel@tonic-gate else
5938*0Sstevel@tonic-gate kid->op_next = k;
5939*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL;
5940*0Sstevel@tonic-gate }
5941*0Sstevel@tonic-gate else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
5942*0Sstevel@tonic-gate op_null(firstkid);
5943*0Sstevel@tonic-gate
5944*0Sstevel@tonic-gate firstkid = firstkid->op_sibling;
5945*0Sstevel@tonic-gate }
5946*0Sstevel@tonic-gate
5947*0Sstevel@tonic-gate /* provide list context for arguments */
5948*0Sstevel@tonic-gate if (o->op_type == OP_SORT)
5949*0Sstevel@tonic-gate list(firstkid);
5950*0Sstevel@tonic-gate
5951*0Sstevel@tonic-gate return o;
5952*0Sstevel@tonic-gate }
5953*0Sstevel@tonic-gate
5954*0Sstevel@tonic-gate STATIC void
S_simplify_sort(pTHX_ OP * o)5955*0Sstevel@tonic-gate S_simplify_sort(pTHX_ OP *o)
5956*0Sstevel@tonic-gate {
5957*0Sstevel@tonic-gate register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5958*0Sstevel@tonic-gate OP *k;
5959*0Sstevel@tonic-gate int reversed;
5960*0Sstevel@tonic-gate GV *gv;
5961*0Sstevel@tonic-gate if (!(o->op_flags & OPf_STACKED))
5962*0Sstevel@tonic-gate return;
5963*0Sstevel@tonic-gate GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
5964*0Sstevel@tonic-gate GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
5965*0Sstevel@tonic-gate kid = kUNOP->op_first; /* get past null */
5966*0Sstevel@tonic-gate if (kid->op_type != OP_SCOPE)
5967*0Sstevel@tonic-gate return;
5968*0Sstevel@tonic-gate kid = kLISTOP->op_last; /* get past scope */
5969*0Sstevel@tonic-gate switch(kid->op_type) {
5970*0Sstevel@tonic-gate case OP_NCMP:
5971*0Sstevel@tonic-gate case OP_I_NCMP:
5972*0Sstevel@tonic-gate case OP_SCMP:
5973*0Sstevel@tonic-gate break;
5974*0Sstevel@tonic-gate default:
5975*0Sstevel@tonic-gate return;
5976*0Sstevel@tonic-gate }
5977*0Sstevel@tonic-gate k = kid; /* remember this node*/
5978*0Sstevel@tonic-gate if (kBINOP->op_first->op_type != OP_RV2SV)
5979*0Sstevel@tonic-gate return;
5980*0Sstevel@tonic-gate kid = kBINOP->op_first; /* get past cmp */
5981*0Sstevel@tonic-gate if (kUNOP->op_first->op_type != OP_GV)
5982*0Sstevel@tonic-gate return;
5983*0Sstevel@tonic-gate kid = kUNOP->op_first; /* get past rv2sv */
5984*0Sstevel@tonic-gate gv = kGVOP_gv;
5985*0Sstevel@tonic-gate if (GvSTASH(gv) != PL_curstash)
5986*0Sstevel@tonic-gate return;
5987*0Sstevel@tonic-gate if (strEQ(GvNAME(gv), "a"))
5988*0Sstevel@tonic-gate reversed = 0;
5989*0Sstevel@tonic-gate else if (strEQ(GvNAME(gv), "b"))
5990*0Sstevel@tonic-gate reversed = 1;
5991*0Sstevel@tonic-gate else
5992*0Sstevel@tonic-gate return;
5993*0Sstevel@tonic-gate kid = k; /* back to cmp */
5994*0Sstevel@tonic-gate if (kBINOP->op_last->op_type != OP_RV2SV)
5995*0Sstevel@tonic-gate return;
5996*0Sstevel@tonic-gate kid = kBINOP->op_last; /* down to 2nd arg */
5997*0Sstevel@tonic-gate if (kUNOP->op_first->op_type != OP_GV)
5998*0Sstevel@tonic-gate return;
5999*0Sstevel@tonic-gate kid = kUNOP->op_first; /* get past rv2sv */
6000*0Sstevel@tonic-gate gv = kGVOP_gv;
6001*0Sstevel@tonic-gate if (GvSTASH(gv) != PL_curstash
6002*0Sstevel@tonic-gate || ( reversed
6003*0Sstevel@tonic-gate ? strNE(GvNAME(gv), "a")
6004*0Sstevel@tonic-gate : strNE(GvNAME(gv), "b")))
6005*0Sstevel@tonic-gate return;
6006*0Sstevel@tonic-gate o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6007*0Sstevel@tonic-gate if (reversed)
6008*0Sstevel@tonic-gate o->op_private |= OPpSORT_REVERSE;
6009*0Sstevel@tonic-gate if (k->op_type == OP_NCMP)
6010*0Sstevel@tonic-gate o->op_private |= OPpSORT_NUMERIC;
6011*0Sstevel@tonic-gate if (k->op_type == OP_I_NCMP)
6012*0Sstevel@tonic-gate o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6013*0Sstevel@tonic-gate kid = cLISTOPo->op_first->op_sibling;
6014*0Sstevel@tonic-gate cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6015*0Sstevel@tonic-gate op_free(kid); /* then delete it */
6016*0Sstevel@tonic-gate }
6017*0Sstevel@tonic-gate
6018*0Sstevel@tonic-gate OP *
Perl_ck_split(pTHX_ OP * o)6019*0Sstevel@tonic-gate Perl_ck_split(pTHX_ OP *o)
6020*0Sstevel@tonic-gate {
6021*0Sstevel@tonic-gate register OP *kid;
6022*0Sstevel@tonic-gate
6023*0Sstevel@tonic-gate if (o->op_flags & OPf_STACKED)
6024*0Sstevel@tonic-gate return no_fh_allowed(o);
6025*0Sstevel@tonic-gate
6026*0Sstevel@tonic-gate kid = cLISTOPo->op_first;
6027*0Sstevel@tonic-gate if (kid->op_type != OP_NULL)
6028*0Sstevel@tonic-gate Perl_croak(aTHX_ "panic: ck_split");
6029*0Sstevel@tonic-gate kid = kid->op_sibling;
6030*0Sstevel@tonic-gate op_free(cLISTOPo->op_first);
6031*0Sstevel@tonic-gate cLISTOPo->op_first = kid;
6032*0Sstevel@tonic-gate if (!kid) {
6033*0Sstevel@tonic-gate cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6034*0Sstevel@tonic-gate cLISTOPo->op_last = kid; /* There was only one element previously */
6035*0Sstevel@tonic-gate }
6036*0Sstevel@tonic-gate
6037*0Sstevel@tonic-gate if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6038*0Sstevel@tonic-gate OP *sibl = kid->op_sibling;
6039*0Sstevel@tonic-gate kid->op_sibling = 0;
6040*0Sstevel@tonic-gate kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6041*0Sstevel@tonic-gate if (cLISTOPo->op_first == cLISTOPo->op_last)
6042*0Sstevel@tonic-gate cLISTOPo->op_last = kid;
6043*0Sstevel@tonic-gate cLISTOPo->op_first = kid;
6044*0Sstevel@tonic-gate kid->op_sibling = sibl;
6045*0Sstevel@tonic-gate }
6046*0Sstevel@tonic-gate
6047*0Sstevel@tonic-gate kid->op_type = OP_PUSHRE;
6048*0Sstevel@tonic-gate kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6049*0Sstevel@tonic-gate scalar(kid);
6050*0Sstevel@tonic-gate if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6051*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6052*0Sstevel@tonic-gate "Use of /g modifier is meaningless in split");
6053*0Sstevel@tonic-gate }
6054*0Sstevel@tonic-gate
6055*0Sstevel@tonic-gate if (!kid->op_sibling)
6056*0Sstevel@tonic-gate append_elem(OP_SPLIT, o, newDEFSVOP());
6057*0Sstevel@tonic-gate
6058*0Sstevel@tonic-gate kid = kid->op_sibling;
6059*0Sstevel@tonic-gate scalar(kid);
6060*0Sstevel@tonic-gate
6061*0Sstevel@tonic-gate if (!kid->op_sibling)
6062*0Sstevel@tonic-gate append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6063*0Sstevel@tonic-gate
6064*0Sstevel@tonic-gate kid = kid->op_sibling;
6065*0Sstevel@tonic-gate scalar(kid);
6066*0Sstevel@tonic-gate
6067*0Sstevel@tonic-gate if (kid->op_sibling)
6068*0Sstevel@tonic-gate return too_many_arguments(o,OP_DESC(o));
6069*0Sstevel@tonic-gate
6070*0Sstevel@tonic-gate return o;
6071*0Sstevel@tonic-gate }
6072*0Sstevel@tonic-gate
6073*0Sstevel@tonic-gate OP *
Perl_ck_join(pTHX_ OP * o)6074*0Sstevel@tonic-gate Perl_ck_join(pTHX_ OP *o)
6075*0Sstevel@tonic-gate {
6076*0Sstevel@tonic-gate if (ckWARN(WARN_SYNTAX)) {
6077*0Sstevel@tonic-gate OP *kid = cLISTOPo->op_first->op_sibling;
6078*0Sstevel@tonic-gate if (kid && kid->op_type == OP_MATCH) {
6079*0Sstevel@tonic-gate char *pmstr = "STRING";
6080*0Sstevel@tonic-gate if (PM_GETRE(kPMOP))
6081*0Sstevel@tonic-gate pmstr = PM_GETRE(kPMOP)->precomp;
6082*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6083*0Sstevel@tonic-gate "/%s/ should probably be written as \"%s\"",
6084*0Sstevel@tonic-gate pmstr, pmstr);
6085*0Sstevel@tonic-gate }
6086*0Sstevel@tonic-gate }
6087*0Sstevel@tonic-gate return ck_fun(o);
6088*0Sstevel@tonic-gate }
6089*0Sstevel@tonic-gate
6090*0Sstevel@tonic-gate OP *
Perl_ck_subr(pTHX_ OP * o)6091*0Sstevel@tonic-gate Perl_ck_subr(pTHX_ OP *o)
6092*0Sstevel@tonic-gate {
6093*0Sstevel@tonic-gate OP *prev = ((cUNOPo->op_first->op_sibling)
6094*0Sstevel@tonic-gate ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6095*0Sstevel@tonic-gate OP *o2 = prev->op_sibling;
6096*0Sstevel@tonic-gate OP *cvop;
6097*0Sstevel@tonic-gate char *proto = 0;
6098*0Sstevel@tonic-gate CV *cv = 0;
6099*0Sstevel@tonic-gate GV *namegv = 0;
6100*0Sstevel@tonic-gate int optional = 0;
6101*0Sstevel@tonic-gate I32 arg = 0;
6102*0Sstevel@tonic-gate I32 contextclass = 0;
6103*0Sstevel@tonic-gate char *e = 0;
6104*0Sstevel@tonic-gate STRLEN n_a;
6105*0Sstevel@tonic-gate
6106*0Sstevel@tonic-gate o->op_private |= OPpENTERSUB_HASTARG;
6107*0Sstevel@tonic-gate for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6108*0Sstevel@tonic-gate if (cvop->op_type == OP_RV2CV) {
6109*0Sstevel@tonic-gate SVOP* tmpop;
6110*0Sstevel@tonic-gate o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6111*0Sstevel@tonic-gate op_null(cvop); /* disable rv2cv */
6112*0Sstevel@tonic-gate tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6113*0Sstevel@tonic-gate if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6114*0Sstevel@tonic-gate GV *gv = cGVOPx_gv(tmpop);
6115*0Sstevel@tonic-gate cv = GvCVu(gv);
6116*0Sstevel@tonic-gate if (!cv)
6117*0Sstevel@tonic-gate tmpop->op_private |= OPpEARLY_CV;
6118*0Sstevel@tonic-gate else if (SvPOK(cv)) {
6119*0Sstevel@tonic-gate namegv = CvANON(cv) ? gv : CvGV(cv);
6120*0Sstevel@tonic-gate proto = SvPV((SV*)cv, n_a);
6121*0Sstevel@tonic-gate }
6122*0Sstevel@tonic-gate }
6123*0Sstevel@tonic-gate }
6124*0Sstevel@tonic-gate else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6125*0Sstevel@tonic-gate if (o2->op_type == OP_CONST)
6126*0Sstevel@tonic-gate o2->op_private &= ~OPpCONST_STRICT;
6127*0Sstevel@tonic-gate else if (o2->op_type == OP_LIST) {
6128*0Sstevel@tonic-gate OP *o = ((UNOP*)o2)->op_first->op_sibling;
6129*0Sstevel@tonic-gate if (o && o->op_type == OP_CONST)
6130*0Sstevel@tonic-gate o->op_private &= ~OPpCONST_STRICT;
6131*0Sstevel@tonic-gate }
6132*0Sstevel@tonic-gate }
6133*0Sstevel@tonic-gate o->op_private |= (PL_hints & HINT_STRICT_REFS);
6134*0Sstevel@tonic-gate if (PERLDB_SUB && PL_curstash != PL_debstash)
6135*0Sstevel@tonic-gate o->op_private |= OPpENTERSUB_DB;
6136*0Sstevel@tonic-gate while (o2 != cvop) {
6137*0Sstevel@tonic-gate if (proto) {
6138*0Sstevel@tonic-gate switch (*proto) {
6139*0Sstevel@tonic-gate case '\0':
6140*0Sstevel@tonic-gate return too_many_arguments(o, gv_ename(namegv));
6141*0Sstevel@tonic-gate case ';':
6142*0Sstevel@tonic-gate optional = 1;
6143*0Sstevel@tonic-gate proto++;
6144*0Sstevel@tonic-gate continue;
6145*0Sstevel@tonic-gate case '$':
6146*0Sstevel@tonic-gate proto++;
6147*0Sstevel@tonic-gate arg++;
6148*0Sstevel@tonic-gate scalar(o2);
6149*0Sstevel@tonic-gate break;
6150*0Sstevel@tonic-gate case '%':
6151*0Sstevel@tonic-gate case '@':
6152*0Sstevel@tonic-gate list(o2);
6153*0Sstevel@tonic-gate arg++;
6154*0Sstevel@tonic-gate break;
6155*0Sstevel@tonic-gate case '&':
6156*0Sstevel@tonic-gate proto++;
6157*0Sstevel@tonic-gate arg++;
6158*0Sstevel@tonic-gate if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6159*0Sstevel@tonic-gate bad_type(arg,
6160*0Sstevel@tonic-gate arg == 1 ? "block or sub {}" : "sub {}",
6161*0Sstevel@tonic-gate gv_ename(namegv), o2);
6162*0Sstevel@tonic-gate break;
6163*0Sstevel@tonic-gate case '*':
6164*0Sstevel@tonic-gate /* '*' allows any scalar type, including bareword */
6165*0Sstevel@tonic-gate proto++;
6166*0Sstevel@tonic-gate arg++;
6167*0Sstevel@tonic-gate if (o2->op_type == OP_RV2GV)
6168*0Sstevel@tonic-gate goto wrapref; /* autoconvert GLOB -> GLOBref */
6169*0Sstevel@tonic-gate else if (o2->op_type == OP_CONST)
6170*0Sstevel@tonic-gate o2->op_private &= ~OPpCONST_STRICT;
6171*0Sstevel@tonic-gate else if (o2->op_type == OP_ENTERSUB) {
6172*0Sstevel@tonic-gate /* accidental subroutine, revert to bareword */
6173*0Sstevel@tonic-gate OP *gvop = ((UNOP*)o2)->op_first;
6174*0Sstevel@tonic-gate if (gvop && gvop->op_type == OP_NULL) {
6175*0Sstevel@tonic-gate gvop = ((UNOP*)gvop)->op_first;
6176*0Sstevel@tonic-gate if (gvop) {
6177*0Sstevel@tonic-gate for (; gvop->op_sibling; gvop = gvop->op_sibling)
6178*0Sstevel@tonic-gate ;
6179*0Sstevel@tonic-gate if (gvop &&
6180*0Sstevel@tonic-gate (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6181*0Sstevel@tonic-gate (gvop = ((UNOP*)gvop)->op_first) &&
6182*0Sstevel@tonic-gate gvop->op_type == OP_GV)
6183*0Sstevel@tonic-gate {
6184*0Sstevel@tonic-gate GV *gv = cGVOPx_gv(gvop);
6185*0Sstevel@tonic-gate OP *sibling = o2->op_sibling;
6186*0Sstevel@tonic-gate SV *n = newSVpvn("",0);
6187*0Sstevel@tonic-gate op_free(o2);
6188*0Sstevel@tonic-gate gv_fullname3(n, gv, "");
6189*0Sstevel@tonic-gate if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6190*0Sstevel@tonic-gate sv_chop(n, SvPVX(n)+6);
6191*0Sstevel@tonic-gate o2 = newSVOP(OP_CONST, 0, n);
6192*0Sstevel@tonic-gate prev->op_sibling = o2;
6193*0Sstevel@tonic-gate o2->op_sibling = sibling;
6194*0Sstevel@tonic-gate }
6195*0Sstevel@tonic-gate }
6196*0Sstevel@tonic-gate }
6197*0Sstevel@tonic-gate }
6198*0Sstevel@tonic-gate scalar(o2);
6199*0Sstevel@tonic-gate break;
6200*0Sstevel@tonic-gate case '[': case ']':
6201*0Sstevel@tonic-gate goto oops;
6202*0Sstevel@tonic-gate break;
6203*0Sstevel@tonic-gate case '\\':
6204*0Sstevel@tonic-gate proto++;
6205*0Sstevel@tonic-gate arg++;
6206*0Sstevel@tonic-gate again:
6207*0Sstevel@tonic-gate switch (*proto++) {
6208*0Sstevel@tonic-gate case '[':
6209*0Sstevel@tonic-gate if (contextclass++ == 0) {
6210*0Sstevel@tonic-gate e = strchr(proto, ']');
6211*0Sstevel@tonic-gate if (!e || e == proto)
6212*0Sstevel@tonic-gate goto oops;
6213*0Sstevel@tonic-gate }
6214*0Sstevel@tonic-gate else
6215*0Sstevel@tonic-gate goto oops;
6216*0Sstevel@tonic-gate goto again;
6217*0Sstevel@tonic-gate break;
6218*0Sstevel@tonic-gate case ']':
6219*0Sstevel@tonic-gate if (contextclass) {
6220*0Sstevel@tonic-gate char *p = proto;
6221*0Sstevel@tonic-gate char s = *p;
6222*0Sstevel@tonic-gate contextclass = 0;
6223*0Sstevel@tonic-gate *p = '\0';
6224*0Sstevel@tonic-gate while (*--p != '[');
6225*0Sstevel@tonic-gate bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6226*0Sstevel@tonic-gate gv_ename(namegv), o2);
6227*0Sstevel@tonic-gate *proto = s;
6228*0Sstevel@tonic-gate } else
6229*0Sstevel@tonic-gate goto oops;
6230*0Sstevel@tonic-gate break;
6231*0Sstevel@tonic-gate case '*':
6232*0Sstevel@tonic-gate if (o2->op_type == OP_RV2GV)
6233*0Sstevel@tonic-gate goto wrapref;
6234*0Sstevel@tonic-gate if (!contextclass)
6235*0Sstevel@tonic-gate bad_type(arg, "symbol", gv_ename(namegv), o2);
6236*0Sstevel@tonic-gate break;
6237*0Sstevel@tonic-gate case '&':
6238*0Sstevel@tonic-gate if (o2->op_type == OP_ENTERSUB)
6239*0Sstevel@tonic-gate goto wrapref;
6240*0Sstevel@tonic-gate if (!contextclass)
6241*0Sstevel@tonic-gate bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6242*0Sstevel@tonic-gate break;
6243*0Sstevel@tonic-gate case '$':
6244*0Sstevel@tonic-gate if (o2->op_type == OP_RV2SV ||
6245*0Sstevel@tonic-gate o2->op_type == OP_PADSV ||
6246*0Sstevel@tonic-gate o2->op_type == OP_HELEM ||
6247*0Sstevel@tonic-gate o2->op_type == OP_AELEM ||
6248*0Sstevel@tonic-gate o2->op_type == OP_THREADSV)
6249*0Sstevel@tonic-gate goto wrapref;
6250*0Sstevel@tonic-gate if (!contextclass)
6251*0Sstevel@tonic-gate bad_type(arg, "scalar", gv_ename(namegv), o2);
6252*0Sstevel@tonic-gate break;
6253*0Sstevel@tonic-gate case '@':
6254*0Sstevel@tonic-gate if (o2->op_type == OP_RV2AV ||
6255*0Sstevel@tonic-gate o2->op_type == OP_PADAV)
6256*0Sstevel@tonic-gate goto wrapref;
6257*0Sstevel@tonic-gate if (!contextclass)
6258*0Sstevel@tonic-gate bad_type(arg, "array", gv_ename(namegv), o2);
6259*0Sstevel@tonic-gate break;
6260*0Sstevel@tonic-gate case '%':
6261*0Sstevel@tonic-gate if (o2->op_type == OP_RV2HV ||
6262*0Sstevel@tonic-gate o2->op_type == OP_PADHV)
6263*0Sstevel@tonic-gate goto wrapref;
6264*0Sstevel@tonic-gate if (!contextclass)
6265*0Sstevel@tonic-gate bad_type(arg, "hash", gv_ename(namegv), o2);
6266*0Sstevel@tonic-gate break;
6267*0Sstevel@tonic-gate wrapref:
6268*0Sstevel@tonic-gate {
6269*0Sstevel@tonic-gate OP* kid = o2;
6270*0Sstevel@tonic-gate OP* sib = kid->op_sibling;
6271*0Sstevel@tonic-gate kid->op_sibling = 0;
6272*0Sstevel@tonic-gate o2 = newUNOP(OP_REFGEN, 0, kid);
6273*0Sstevel@tonic-gate o2->op_sibling = sib;
6274*0Sstevel@tonic-gate prev->op_sibling = o2;
6275*0Sstevel@tonic-gate }
6276*0Sstevel@tonic-gate if (contextclass && e) {
6277*0Sstevel@tonic-gate proto = e + 1;
6278*0Sstevel@tonic-gate contextclass = 0;
6279*0Sstevel@tonic-gate }
6280*0Sstevel@tonic-gate break;
6281*0Sstevel@tonic-gate default: goto oops;
6282*0Sstevel@tonic-gate }
6283*0Sstevel@tonic-gate if (contextclass)
6284*0Sstevel@tonic-gate goto again;
6285*0Sstevel@tonic-gate break;
6286*0Sstevel@tonic-gate case ' ':
6287*0Sstevel@tonic-gate proto++;
6288*0Sstevel@tonic-gate continue;
6289*0Sstevel@tonic-gate default:
6290*0Sstevel@tonic-gate oops:
6291*0Sstevel@tonic-gate Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6292*0Sstevel@tonic-gate gv_ename(namegv), cv);
6293*0Sstevel@tonic-gate }
6294*0Sstevel@tonic-gate }
6295*0Sstevel@tonic-gate else
6296*0Sstevel@tonic-gate list(o2);
6297*0Sstevel@tonic-gate mod(o2, OP_ENTERSUB);
6298*0Sstevel@tonic-gate prev = o2;
6299*0Sstevel@tonic-gate o2 = o2->op_sibling;
6300*0Sstevel@tonic-gate }
6301*0Sstevel@tonic-gate if (proto && !optional &&
6302*0Sstevel@tonic-gate (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6303*0Sstevel@tonic-gate return too_few_arguments(o, gv_ename(namegv));
6304*0Sstevel@tonic-gate return o;
6305*0Sstevel@tonic-gate }
6306*0Sstevel@tonic-gate
6307*0Sstevel@tonic-gate OP *
Perl_ck_svconst(pTHX_ OP * o)6308*0Sstevel@tonic-gate Perl_ck_svconst(pTHX_ OP *o)
6309*0Sstevel@tonic-gate {
6310*0Sstevel@tonic-gate SvREADONLY_on(cSVOPo->op_sv);
6311*0Sstevel@tonic-gate return o;
6312*0Sstevel@tonic-gate }
6313*0Sstevel@tonic-gate
6314*0Sstevel@tonic-gate OP *
Perl_ck_trunc(pTHX_ OP * o)6315*0Sstevel@tonic-gate Perl_ck_trunc(pTHX_ OP *o)
6316*0Sstevel@tonic-gate {
6317*0Sstevel@tonic-gate if (o->op_flags & OPf_KIDS) {
6318*0Sstevel@tonic-gate SVOP *kid = (SVOP*)cUNOPo->op_first;
6319*0Sstevel@tonic-gate
6320*0Sstevel@tonic-gate if (kid->op_type == OP_NULL)
6321*0Sstevel@tonic-gate kid = (SVOP*)kid->op_sibling;
6322*0Sstevel@tonic-gate if (kid && kid->op_type == OP_CONST &&
6323*0Sstevel@tonic-gate (kid->op_private & OPpCONST_BARE))
6324*0Sstevel@tonic-gate {
6325*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL;
6326*0Sstevel@tonic-gate kid->op_private &= ~OPpCONST_STRICT;
6327*0Sstevel@tonic-gate }
6328*0Sstevel@tonic-gate }
6329*0Sstevel@tonic-gate return ck_fun(o);
6330*0Sstevel@tonic-gate }
6331*0Sstevel@tonic-gate
6332*0Sstevel@tonic-gate OP *
Perl_ck_substr(pTHX_ OP * o)6333*0Sstevel@tonic-gate Perl_ck_substr(pTHX_ OP *o)
6334*0Sstevel@tonic-gate {
6335*0Sstevel@tonic-gate o = ck_fun(o);
6336*0Sstevel@tonic-gate if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6337*0Sstevel@tonic-gate OP *kid = cLISTOPo->op_first;
6338*0Sstevel@tonic-gate
6339*0Sstevel@tonic-gate if (kid->op_type == OP_NULL)
6340*0Sstevel@tonic-gate kid = kid->op_sibling;
6341*0Sstevel@tonic-gate if (kid)
6342*0Sstevel@tonic-gate kid->op_flags |= OPf_MOD;
6343*0Sstevel@tonic-gate
6344*0Sstevel@tonic-gate }
6345*0Sstevel@tonic-gate return o;
6346*0Sstevel@tonic-gate }
6347*0Sstevel@tonic-gate
6348*0Sstevel@tonic-gate /* A peephole optimizer. We visit the ops in the order they're to execute. */
6349*0Sstevel@tonic-gate
6350*0Sstevel@tonic-gate void
Perl_peep(pTHX_ register OP * o)6351*0Sstevel@tonic-gate Perl_peep(pTHX_ register OP *o)
6352*0Sstevel@tonic-gate {
6353*0Sstevel@tonic-gate register OP* oldop = 0;
6354*0Sstevel@tonic-gate STRLEN n_a;
6355*0Sstevel@tonic-gate
6356*0Sstevel@tonic-gate if (!o || o->op_seq)
6357*0Sstevel@tonic-gate return;
6358*0Sstevel@tonic-gate ENTER;
6359*0Sstevel@tonic-gate SAVEOP();
6360*0Sstevel@tonic-gate SAVEVPTR(PL_curcop);
6361*0Sstevel@tonic-gate for (; o; o = o->op_next) {
6362*0Sstevel@tonic-gate if (o->op_seq)
6363*0Sstevel@tonic-gate break;
6364*0Sstevel@tonic-gate /* The special value -1 is used by the B::C compiler backend to indicate
6365*0Sstevel@tonic-gate * that an op is statically defined and should not be freed */
6366*0Sstevel@tonic-gate if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
6367*0Sstevel@tonic-gate PL_op_seqmax = 1;
6368*0Sstevel@tonic-gate PL_op = o;
6369*0Sstevel@tonic-gate switch (o->op_type) {
6370*0Sstevel@tonic-gate case OP_SETSTATE:
6371*0Sstevel@tonic-gate case OP_NEXTSTATE:
6372*0Sstevel@tonic-gate case OP_DBSTATE:
6373*0Sstevel@tonic-gate PL_curcop = ((COP*)o); /* for warnings */
6374*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6375*0Sstevel@tonic-gate break;
6376*0Sstevel@tonic-gate
6377*0Sstevel@tonic-gate case OP_CONST:
6378*0Sstevel@tonic-gate if (cSVOPo->op_private & OPpCONST_STRICT)
6379*0Sstevel@tonic-gate no_bareword_allowed(o);
6380*0Sstevel@tonic-gate #ifdef USE_ITHREADS
6381*0Sstevel@tonic-gate case OP_METHOD_NAMED:
6382*0Sstevel@tonic-gate /* Relocate sv to the pad for thread safety.
6383*0Sstevel@tonic-gate * Despite being a "constant", the SV is written to,
6384*0Sstevel@tonic-gate * for reference counts, sv_upgrade() etc. */
6385*0Sstevel@tonic-gate if (cSVOP->op_sv) {
6386*0Sstevel@tonic-gate PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6387*0Sstevel@tonic-gate if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6388*0Sstevel@tonic-gate /* If op_sv is already a PADTMP then it is being used by
6389*0Sstevel@tonic-gate * some pad, so make a copy. */
6390*0Sstevel@tonic-gate sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6391*0Sstevel@tonic-gate SvREADONLY_on(PAD_SVl(ix));
6392*0Sstevel@tonic-gate SvREFCNT_dec(cSVOPo->op_sv);
6393*0Sstevel@tonic-gate }
6394*0Sstevel@tonic-gate else {
6395*0Sstevel@tonic-gate SvREFCNT_dec(PAD_SVl(ix));
6396*0Sstevel@tonic-gate SvPADTMP_on(cSVOPo->op_sv);
6397*0Sstevel@tonic-gate PAD_SETSV(ix, cSVOPo->op_sv);
6398*0Sstevel@tonic-gate /* XXX I don't know how this isn't readonly already. */
6399*0Sstevel@tonic-gate SvREADONLY_on(PAD_SVl(ix));
6400*0Sstevel@tonic-gate }
6401*0Sstevel@tonic-gate cSVOPo->op_sv = Nullsv;
6402*0Sstevel@tonic-gate o->op_targ = ix;
6403*0Sstevel@tonic-gate }
6404*0Sstevel@tonic-gate #endif
6405*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6406*0Sstevel@tonic-gate break;
6407*0Sstevel@tonic-gate
6408*0Sstevel@tonic-gate case OP_CONCAT:
6409*0Sstevel@tonic-gate if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6410*0Sstevel@tonic-gate if (o->op_next->op_private & OPpTARGET_MY) {
6411*0Sstevel@tonic-gate if (o->op_flags & OPf_STACKED) /* chained concats */
6412*0Sstevel@tonic-gate goto ignore_optimization;
6413*0Sstevel@tonic-gate else {
6414*0Sstevel@tonic-gate /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6415*0Sstevel@tonic-gate o->op_targ = o->op_next->op_targ;
6416*0Sstevel@tonic-gate o->op_next->op_targ = 0;
6417*0Sstevel@tonic-gate o->op_private |= OPpTARGET_MY;
6418*0Sstevel@tonic-gate }
6419*0Sstevel@tonic-gate }
6420*0Sstevel@tonic-gate op_null(o->op_next);
6421*0Sstevel@tonic-gate }
6422*0Sstevel@tonic-gate ignore_optimization:
6423*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6424*0Sstevel@tonic-gate break;
6425*0Sstevel@tonic-gate case OP_STUB:
6426*0Sstevel@tonic-gate if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6427*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6428*0Sstevel@tonic-gate break; /* Scalar stub must produce undef. List stub is noop */
6429*0Sstevel@tonic-gate }
6430*0Sstevel@tonic-gate goto nothin;
6431*0Sstevel@tonic-gate case OP_NULL:
6432*0Sstevel@tonic-gate if (o->op_targ == OP_NEXTSTATE
6433*0Sstevel@tonic-gate || o->op_targ == OP_DBSTATE
6434*0Sstevel@tonic-gate || o->op_targ == OP_SETSTATE)
6435*0Sstevel@tonic-gate {
6436*0Sstevel@tonic-gate PL_curcop = ((COP*)o);
6437*0Sstevel@tonic-gate }
6438*0Sstevel@tonic-gate /* XXX: We avoid setting op_seq here to prevent later calls
6439*0Sstevel@tonic-gate to peep() from mistakenly concluding that optimisation
6440*0Sstevel@tonic-gate has already occurred. This doesn't fix the real problem,
6441*0Sstevel@tonic-gate though (See 20010220.007). AMS 20010719 */
6442*0Sstevel@tonic-gate if (oldop && o->op_next) {
6443*0Sstevel@tonic-gate oldop->op_next = o->op_next;
6444*0Sstevel@tonic-gate continue;
6445*0Sstevel@tonic-gate }
6446*0Sstevel@tonic-gate break;
6447*0Sstevel@tonic-gate case OP_SCALAR:
6448*0Sstevel@tonic-gate case OP_LINESEQ:
6449*0Sstevel@tonic-gate case OP_SCOPE:
6450*0Sstevel@tonic-gate nothin:
6451*0Sstevel@tonic-gate if (oldop && o->op_next) {
6452*0Sstevel@tonic-gate oldop->op_next = o->op_next;
6453*0Sstevel@tonic-gate continue;
6454*0Sstevel@tonic-gate }
6455*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6456*0Sstevel@tonic-gate break;
6457*0Sstevel@tonic-gate
6458*0Sstevel@tonic-gate case OP_PADAV:
6459*0Sstevel@tonic-gate case OP_GV:
6460*0Sstevel@tonic-gate if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6461*0Sstevel@tonic-gate OP* pop = (o->op_type == OP_PADAV) ?
6462*0Sstevel@tonic-gate o->op_next : o->op_next->op_next;
6463*0Sstevel@tonic-gate IV i;
6464*0Sstevel@tonic-gate if (pop && pop->op_type == OP_CONST &&
6465*0Sstevel@tonic-gate ((PL_op = pop->op_next)) &&
6466*0Sstevel@tonic-gate pop->op_next->op_type == OP_AELEM &&
6467*0Sstevel@tonic-gate !(pop->op_next->op_private &
6468*0Sstevel@tonic-gate (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6469*0Sstevel@tonic-gate (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6470*0Sstevel@tonic-gate <= 255 &&
6471*0Sstevel@tonic-gate i >= 0)
6472*0Sstevel@tonic-gate {
6473*0Sstevel@tonic-gate GV *gv;
6474*0Sstevel@tonic-gate if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6475*0Sstevel@tonic-gate no_bareword_allowed(pop);
6476*0Sstevel@tonic-gate if (o->op_type == OP_GV)
6477*0Sstevel@tonic-gate op_null(o->op_next);
6478*0Sstevel@tonic-gate op_null(pop->op_next);
6479*0Sstevel@tonic-gate op_null(pop);
6480*0Sstevel@tonic-gate o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6481*0Sstevel@tonic-gate o->op_next = pop->op_next->op_next;
6482*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6483*0Sstevel@tonic-gate o->op_private = (U8)i;
6484*0Sstevel@tonic-gate if (o->op_type == OP_GV) {
6485*0Sstevel@tonic-gate gv = cGVOPo_gv;
6486*0Sstevel@tonic-gate GvAVn(gv);
6487*0Sstevel@tonic-gate }
6488*0Sstevel@tonic-gate else
6489*0Sstevel@tonic-gate o->op_flags |= OPf_SPECIAL;
6490*0Sstevel@tonic-gate o->op_type = OP_AELEMFAST;
6491*0Sstevel@tonic-gate }
6492*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6493*0Sstevel@tonic-gate break;
6494*0Sstevel@tonic-gate }
6495*0Sstevel@tonic-gate
6496*0Sstevel@tonic-gate if (o->op_next->op_type == OP_RV2SV) {
6497*0Sstevel@tonic-gate if (!(o->op_next->op_private & OPpDEREF)) {
6498*0Sstevel@tonic-gate op_null(o->op_next);
6499*0Sstevel@tonic-gate o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6500*0Sstevel@tonic-gate | OPpOUR_INTRO);
6501*0Sstevel@tonic-gate o->op_next = o->op_next->op_next;
6502*0Sstevel@tonic-gate o->op_type = OP_GVSV;
6503*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_GVSV];
6504*0Sstevel@tonic-gate }
6505*0Sstevel@tonic-gate }
6506*0Sstevel@tonic-gate else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6507*0Sstevel@tonic-gate GV *gv = cGVOPo_gv;
6508*0Sstevel@tonic-gate if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6509*0Sstevel@tonic-gate /* XXX could check prototype here instead of just carping */
6510*0Sstevel@tonic-gate SV *sv = sv_newmortal();
6511*0Sstevel@tonic-gate gv_efullname3(sv, gv, Nullch);
6512*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6513*0Sstevel@tonic-gate "%"SVf"() called too early to check prototype",
6514*0Sstevel@tonic-gate sv);
6515*0Sstevel@tonic-gate }
6516*0Sstevel@tonic-gate }
6517*0Sstevel@tonic-gate else if (o->op_next->op_type == OP_READLINE
6518*0Sstevel@tonic-gate && o->op_next->op_next->op_type == OP_CONCAT
6519*0Sstevel@tonic-gate && (o->op_next->op_next->op_flags & OPf_STACKED))
6520*0Sstevel@tonic-gate {
6521*0Sstevel@tonic-gate /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6522*0Sstevel@tonic-gate o->op_type = OP_RCATLINE;
6523*0Sstevel@tonic-gate o->op_flags |= OPf_STACKED;
6524*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6525*0Sstevel@tonic-gate op_null(o->op_next->op_next);
6526*0Sstevel@tonic-gate op_null(o->op_next);
6527*0Sstevel@tonic-gate }
6528*0Sstevel@tonic-gate
6529*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6530*0Sstevel@tonic-gate break;
6531*0Sstevel@tonic-gate
6532*0Sstevel@tonic-gate case OP_MAPWHILE:
6533*0Sstevel@tonic-gate case OP_GREPWHILE:
6534*0Sstevel@tonic-gate case OP_AND:
6535*0Sstevel@tonic-gate case OP_OR:
6536*0Sstevel@tonic-gate case OP_ANDASSIGN:
6537*0Sstevel@tonic-gate case OP_ORASSIGN:
6538*0Sstevel@tonic-gate case OP_COND_EXPR:
6539*0Sstevel@tonic-gate case OP_RANGE:
6540*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6541*0Sstevel@tonic-gate while (cLOGOP->op_other->op_type == OP_NULL)
6542*0Sstevel@tonic-gate cLOGOP->op_other = cLOGOP->op_other->op_next;
6543*0Sstevel@tonic-gate peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6544*0Sstevel@tonic-gate break;
6545*0Sstevel@tonic-gate
6546*0Sstevel@tonic-gate case OP_ENTERLOOP:
6547*0Sstevel@tonic-gate case OP_ENTERITER:
6548*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6549*0Sstevel@tonic-gate while (cLOOP->op_redoop->op_type == OP_NULL)
6550*0Sstevel@tonic-gate cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6551*0Sstevel@tonic-gate peep(cLOOP->op_redoop);
6552*0Sstevel@tonic-gate while (cLOOP->op_nextop->op_type == OP_NULL)
6553*0Sstevel@tonic-gate cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6554*0Sstevel@tonic-gate peep(cLOOP->op_nextop);
6555*0Sstevel@tonic-gate while (cLOOP->op_lastop->op_type == OP_NULL)
6556*0Sstevel@tonic-gate cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6557*0Sstevel@tonic-gate peep(cLOOP->op_lastop);
6558*0Sstevel@tonic-gate break;
6559*0Sstevel@tonic-gate
6560*0Sstevel@tonic-gate case OP_QR:
6561*0Sstevel@tonic-gate case OP_MATCH:
6562*0Sstevel@tonic-gate case OP_SUBST:
6563*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6564*0Sstevel@tonic-gate while (cPMOP->op_pmreplstart &&
6565*0Sstevel@tonic-gate cPMOP->op_pmreplstart->op_type == OP_NULL)
6566*0Sstevel@tonic-gate cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6567*0Sstevel@tonic-gate peep(cPMOP->op_pmreplstart);
6568*0Sstevel@tonic-gate break;
6569*0Sstevel@tonic-gate
6570*0Sstevel@tonic-gate case OP_EXEC:
6571*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6572*0Sstevel@tonic-gate if (ckWARN(WARN_SYNTAX) && o->op_next
6573*0Sstevel@tonic-gate && o->op_next->op_type == OP_NEXTSTATE) {
6574*0Sstevel@tonic-gate if (o->op_next->op_sibling &&
6575*0Sstevel@tonic-gate o->op_next->op_sibling->op_type != OP_EXIT &&
6576*0Sstevel@tonic-gate o->op_next->op_sibling->op_type != OP_WARN &&
6577*0Sstevel@tonic-gate o->op_next->op_sibling->op_type != OP_DIE) {
6578*0Sstevel@tonic-gate line_t oldline = CopLINE(PL_curcop);
6579*0Sstevel@tonic-gate
6580*0Sstevel@tonic-gate CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6581*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_EXEC),
6582*0Sstevel@tonic-gate "Statement unlikely to be reached");
6583*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_EXEC),
6584*0Sstevel@tonic-gate "\t(Maybe you meant system() when you said exec()?)\n");
6585*0Sstevel@tonic-gate CopLINE_set(PL_curcop, oldline);
6586*0Sstevel@tonic-gate }
6587*0Sstevel@tonic-gate }
6588*0Sstevel@tonic-gate break;
6589*0Sstevel@tonic-gate
6590*0Sstevel@tonic-gate case OP_HELEM: {
6591*0Sstevel@tonic-gate UNOP *rop;
6592*0Sstevel@tonic-gate SV *lexname;
6593*0Sstevel@tonic-gate GV **fields;
6594*0Sstevel@tonic-gate SV **svp, **indsvp, *sv;
6595*0Sstevel@tonic-gate I32 ind;
6596*0Sstevel@tonic-gate char *key = NULL;
6597*0Sstevel@tonic-gate STRLEN keylen;
6598*0Sstevel@tonic-gate
6599*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6600*0Sstevel@tonic-gate
6601*0Sstevel@tonic-gate if (((BINOP*)o)->op_last->op_type != OP_CONST)
6602*0Sstevel@tonic-gate break;
6603*0Sstevel@tonic-gate
6604*0Sstevel@tonic-gate /* Make the CONST have a shared SV */
6605*0Sstevel@tonic-gate svp = cSVOPx_svp(((BINOP*)o)->op_last);
6606*0Sstevel@tonic-gate if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6607*0Sstevel@tonic-gate key = SvPV(sv, keylen);
6608*0Sstevel@tonic-gate lexname = newSVpvn_share(key,
6609*0Sstevel@tonic-gate SvUTF8(sv) ? -(I32)keylen : keylen,
6610*0Sstevel@tonic-gate 0);
6611*0Sstevel@tonic-gate SvREFCNT_dec(sv);
6612*0Sstevel@tonic-gate *svp = lexname;
6613*0Sstevel@tonic-gate }
6614*0Sstevel@tonic-gate
6615*0Sstevel@tonic-gate if ((o->op_private & (OPpLVAL_INTRO)))
6616*0Sstevel@tonic-gate break;
6617*0Sstevel@tonic-gate
6618*0Sstevel@tonic-gate rop = (UNOP*)((BINOP*)o)->op_first;
6619*0Sstevel@tonic-gate if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6620*0Sstevel@tonic-gate break;
6621*0Sstevel@tonic-gate lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6622*0Sstevel@tonic-gate if (!(SvFLAGS(lexname) & SVpad_TYPED))
6623*0Sstevel@tonic-gate break;
6624*0Sstevel@tonic-gate fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6625*0Sstevel@tonic-gate if (!fields || !GvHV(*fields))
6626*0Sstevel@tonic-gate break;
6627*0Sstevel@tonic-gate key = SvPV(*svp, keylen);
6628*0Sstevel@tonic-gate indsvp = hv_fetch(GvHV(*fields), key,
6629*0Sstevel@tonic-gate SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6630*0Sstevel@tonic-gate if (!indsvp) {
6631*0Sstevel@tonic-gate Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6632*0Sstevel@tonic-gate key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6633*0Sstevel@tonic-gate }
6634*0Sstevel@tonic-gate ind = SvIV(*indsvp);
6635*0Sstevel@tonic-gate if (ind < 1)
6636*0Sstevel@tonic-gate Perl_croak(aTHX_ "Bad index while coercing array into hash");
6637*0Sstevel@tonic-gate rop->op_type = OP_RV2AV;
6638*0Sstevel@tonic-gate rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6639*0Sstevel@tonic-gate o->op_type = OP_AELEM;
6640*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_AELEM];
6641*0Sstevel@tonic-gate sv = newSViv(ind);
6642*0Sstevel@tonic-gate if (SvREADONLY(*svp))
6643*0Sstevel@tonic-gate SvREADONLY_on(sv);
6644*0Sstevel@tonic-gate SvFLAGS(sv) |= (SvFLAGS(*svp)
6645*0Sstevel@tonic-gate & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6646*0Sstevel@tonic-gate SvREFCNT_dec(*svp);
6647*0Sstevel@tonic-gate *svp = sv;
6648*0Sstevel@tonic-gate break;
6649*0Sstevel@tonic-gate }
6650*0Sstevel@tonic-gate
6651*0Sstevel@tonic-gate case OP_HSLICE: {
6652*0Sstevel@tonic-gate UNOP *rop;
6653*0Sstevel@tonic-gate SV *lexname;
6654*0Sstevel@tonic-gate GV **fields;
6655*0Sstevel@tonic-gate SV **svp, **indsvp, *sv;
6656*0Sstevel@tonic-gate I32 ind;
6657*0Sstevel@tonic-gate char *key;
6658*0Sstevel@tonic-gate STRLEN keylen;
6659*0Sstevel@tonic-gate SVOP *first_key_op, *key_op;
6660*0Sstevel@tonic-gate
6661*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6662*0Sstevel@tonic-gate if ((o->op_private & (OPpLVAL_INTRO))
6663*0Sstevel@tonic-gate /* I bet there's always a pushmark... */
6664*0Sstevel@tonic-gate || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6665*0Sstevel@tonic-gate /* hmmm, no optimization if list contains only one key. */
6666*0Sstevel@tonic-gate break;
6667*0Sstevel@tonic-gate rop = (UNOP*)((LISTOP*)o)->op_last;
6668*0Sstevel@tonic-gate if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6669*0Sstevel@tonic-gate break;
6670*0Sstevel@tonic-gate lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6671*0Sstevel@tonic-gate if (!(SvFLAGS(lexname) & SVpad_TYPED))
6672*0Sstevel@tonic-gate break;
6673*0Sstevel@tonic-gate fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6674*0Sstevel@tonic-gate if (!fields || !GvHV(*fields))
6675*0Sstevel@tonic-gate break;
6676*0Sstevel@tonic-gate /* Again guessing that the pushmark can be jumped over.... */
6677*0Sstevel@tonic-gate first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6678*0Sstevel@tonic-gate ->op_first->op_sibling;
6679*0Sstevel@tonic-gate /* Check that the key list contains only constants. */
6680*0Sstevel@tonic-gate for (key_op = first_key_op; key_op;
6681*0Sstevel@tonic-gate key_op = (SVOP*)key_op->op_sibling)
6682*0Sstevel@tonic-gate if (key_op->op_type != OP_CONST)
6683*0Sstevel@tonic-gate break;
6684*0Sstevel@tonic-gate if (key_op)
6685*0Sstevel@tonic-gate break;
6686*0Sstevel@tonic-gate rop->op_type = OP_RV2AV;
6687*0Sstevel@tonic-gate rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6688*0Sstevel@tonic-gate o->op_type = OP_ASLICE;
6689*0Sstevel@tonic-gate o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6690*0Sstevel@tonic-gate for (key_op = first_key_op; key_op;
6691*0Sstevel@tonic-gate key_op = (SVOP*)key_op->op_sibling) {
6692*0Sstevel@tonic-gate svp = cSVOPx_svp(key_op);
6693*0Sstevel@tonic-gate key = SvPV(*svp, keylen);
6694*0Sstevel@tonic-gate indsvp = hv_fetch(GvHV(*fields), key,
6695*0Sstevel@tonic-gate SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
6696*0Sstevel@tonic-gate if (!indsvp) {
6697*0Sstevel@tonic-gate Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6698*0Sstevel@tonic-gate "in variable %s of type %s",
6699*0Sstevel@tonic-gate key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6700*0Sstevel@tonic-gate }
6701*0Sstevel@tonic-gate ind = SvIV(*indsvp);
6702*0Sstevel@tonic-gate if (ind < 1)
6703*0Sstevel@tonic-gate Perl_croak(aTHX_ "Bad index while coercing array into hash");
6704*0Sstevel@tonic-gate sv = newSViv(ind);
6705*0Sstevel@tonic-gate if (SvREADONLY(*svp))
6706*0Sstevel@tonic-gate SvREADONLY_on(sv);
6707*0Sstevel@tonic-gate SvFLAGS(sv) |= (SvFLAGS(*svp)
6708*0Sstevel@tonic-gate & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6709*0Sstevel@tonic-gate SvREFCNT_dec(*svp);
6710*0Sstevel@tonic-gate *svp = sv;
6711*0Sstevel@tonic-gate }
6712*0Sstevel@tonic-gate break;
6713*0Sstevel@tonic-gate }
6714*0Sstevel@tonic-gate
6715*0Sstevel@tonic-gate case OP_SORT: {
6716*0Sstevel@tonic-gate /* make @a = sort @a act in-place */
6717*0Sstevel@tonic-gate
6718*0Sstevel@tonic-gate /* will point to RV2AV or PADAV op on LHS/RHS of assign */
6719*0Sstevel@tonic-gate OP *oleft, *oright;
6720*0Sstevel@tonic-gate OP *o2;
6721*0Sstevel@tonic-gate
6722*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6723*0Sstevel@tonic-gate
6724*0Sstevel@tonic-gate /* check that RHS of sort is a single plain array */
6725*0Sstevel@tonic-gate oright = cUNOPo->op_first;
6726*0Sstevel@tonic-gate if (!oright || oright->op_type != OP_PUSHMARK)
6727*0Sstevel@tonic-gate break;
6728*0Sstevel@tonic-gate oright = cUNOPx(oright)->op_sibling;
6729*0Sstevel@tonic-gate if (!oright)
6730*0Sstevel@tonic-gate break;
6731*0Sstevel@tonic-gate if (oright->op_type == OP_NULL) { /* skip sort block/sub */
6732*0Sstevel@tonic-gate oright = cUNOPx(oright)->op_sibling;
6733*0Sstevel@tonic-gate }
6734*0Sstevel@tonic-gate
6735*0Sstevel@tonic-gate if (!oright ||
6736*0Sstevel@tonic-gate (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
6737*0Sstevel@tonic-gate || oright->op_next != o
6738*0Sstevel@tonic-gate || (oright->op_private & OPpLVAL_INTRO)
6739*0Sstevel@tonic-gate )
6740*0Sstevel@tonic-gate break;
6741*0Sstevel@tonic-gate
6742*0Sstevel@tonic-gate /* o2 follows the chain of op_nexts through the LHS of the
6743*0Sstevel@tonic-gate * assign (if any) to the aassign op itself */
6744*0Sstevel@tonic-gate o2 = o->op_next;
6745*0Sstevel@tonic-gate if (!o2 || o2->op_type != OP_NULL)
6746*0Sstevel@tonic-gate break;
6747*0Sstevel@tonic-gate o2 = o2->op_next;
6748*0Sstevel@tonic-gate if (!o2 || o2->op_type != OP_PUSHMARK)
6749*0Sstevel@tonic-gate break;
6750*0Sstevel@tonic-gate o2 = o2->op_next;
6751*0Sstevel@tonic-gate if (o2 && o2->op_type == OP_GV)
6752*0Sstevel@tonic-gate o2 = o2->op_next;
6753*0Sstevel@tonic-gate if (!o2
6754*0Sstevel@tonic-gate || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
6755*0Sstevel@tonic-gate || (o2->op_private & OPpLVAL_INTRO)
6756*0Sstevel@tonic-gate )
6757*0Sstevel@tonic-gate break;
6758*0Sstevel@tonic-gate oleft = o2;
6759*0Sstevel@tonic-gate o2 = o2->op_next;
6760*0Sstevel@tonic-gate if (!o2 || o2->op_type != OP_NULL)
6761*0Sstevel@tonic-gate break;
6762*0Sstevel@tonic-gate o2 = o2->op_next;
6763*0Sstevel@tonic-gate if (!o2 || o2->op_type != OP_AASSIGN
6764*0Sstevel@tonic-gate || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
6765*0Sstevel@tonic-gate break;
6766*0Sstevel@tonic-gate
6767*0Sstevel@tonic-gate /* check that the sort is the first arg on RHS of assign */
6768*0Sstevel@tonic-gate
6769*0Sstevel@tonic-gate o2 = cUNOPx(o2)->op_first;
6770*0Sstevel@tonic-gate if (!o2 || o2->op_type != OP_NULL)
6771*0Sstevel@tonic-gate break;
6772*0Sstevel@tonic-gate o2 = cUNOPx(o2)->op_first;
6773*0Sstevel@tonic-gate if (!o2 || o2->op_type != OP_PUSHMARK)
6774*0Sstevel@tonic-gate break;
6775*0Sstevel@tonic-gate if (o2->op_sibling != o)
6776*0Sstevel@tonic-gate break;
6777*0Sstevel@tonic-gate
6778*0Sstevel@tonic-gate /* check the array is the same on both sides */
6779*0Sstevel@tonic-gate if (oleft->op_type == OP_RV2AV) {
6780*0Sstevel@tonic-gate if (oright->op_type != OP_RV2AV
6781*0Sstevel@tonic-gate || !cUNOPx(oright)->op_first
6782*0Sstevel@tonic-gate || cUNOPx(oright)->op_first->op_type != OP_GV
6783*0Sstevel@tonic-gate || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
6784*0Sstevel@tonic-gate cGVOPx_gv(cUNOPx(oright)->op_first)
6785*0Sstevel@tonic-gate )
6786*0Sstevel@tonic-gate break;
6787*0Sstevel@tonic-gate }
6788*0Sstevel@tonic-gate else if (oright->op_type != OP_PADAV
6789*0Sstevel@tonic-gate || oright->op_targ != oleft->op_targ
6790*0Sstevel@tonic-gate )
6791*0Sstevel@tonic-gate break;
6792*0Sstevel@tonic-gate
6793*0Sstevel@tonic-gate /* transfer MODishness etc from LHS arg to RHS arg */
6794*0Sstevel@tonic-gate oright->op_flags = oleft->op_flags;
6795*0Sstevel@tonic-gate o->op_private |= OPpSORT_INPLACE;
6796*0Sstevel@tonic-gate
6797*0Sstevel@tonic-gate /* excise push->gv->rv2av->null->aassign */
6798*0Sstevel@tonic-gate o2 = o->op_next->op_next;
6799*0Sstevel@tonic-gate op_null(o2); /* PUSHMARK */
6800*0Sstevel@tonic-gate o2 = o2->op_next;
6801*0Sstevel@tonic-gate if (o2->op_type == OP_GV) {
6802*0Sstevel@tonic-gate op_null(o2); /* GV */
6803*0Sstevel@tonic-gate o2 = o2->op_next;
6804*0Sstevel@tonic-gate }
6805*0Sstevel@tonic-gate op_null(o2); /* RV2AV or PADAV */
6806*0Sstevel@tonic-gate o2 = o2->op_next->op_next;
6807*0Sstevel@tonic-gate op_null(o2); /* AASSIGN */
6808*0Sstevel@tonic-gate
6809*0Sstevel@tonic-gate o->op_next = o2->op_next;
6810*0Sstevel@tonic-gate
6811*0Sstevel@tonic-gate break;
6812*0Sstevel@tonic-gate }
6813*0Sstevel@tonic-gate
6814*0Sstevel@tonic-gate
6815*0Sstevel@tonic-gate
6816*0Sstevel@tonic-gate default:
6817*0Sstevel@tonic-gate o->op_seq = PL_op_seqmax++;
6818*0Sstevel@tonic-gate break;
6819*0Sstevel@tonic-gate }
6820*0Sstevel@tonic-gate oldop = o;
6821*0Sstevel@tonic-gate }
6822*0Sstevel@tonic-gate LEAVE;
6823*0Sstevel@tonic-gate }
6824*0Sstevel@tonic-gate
6825*0Sstevel@tonic-gate
6826*0Sstevel@tonic-gate
Perl_custom_op_name(pTHX_ OP * o)6827*0Sstevel@tonic-gate char* Perl_custom_op_name(pTHX_ OP* o)
6828*0Sstevel@tonic-gate {
6829*0Sstevel@tonic-gate IV index = PTR2IV(o->op_ppaddr);
6830*0Sstevel@tonic-gate SV* keysv;
6831*0Sstevel@tonic-gate HE* he;
6832*0Sstevel@tonic-gate
6833*0Sstevel@tonic-gate if (!PL_custom_op_names) /* This probably shouldn't happen */
6834*0Sstevel@tonic-gate return PL_op_name[OP_CUSTOM];
6835*0Sstevel@tonic-gate
6836*0Sstevel@tonic-gate keysv = sv_2mortal(newSViv(index));
6837*0Sstevel@tonic-gate
6838*0Sstevel@tonic-gate he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
6839*0Sstevel@tonic-gate if (!he)
6840*0Sstevel@tonic-gate return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
6841*0Sstevel@tonic-gate
6842*0Sstevel@tonic-gate return SvPV_nolen(HeVAL(he));
6843*0Sstevel@tonic-gate }
6844*0Sstevel@tonic-gate
Perl_custom_op_desc(pTHX_ OP * o)6845*0Sstevel@tonic-gate char* Perl_custom_op_desc(pTHX_ OP* o)
6846*0Sstevel@tonic-gate {
6847*0Sstevel@tonic-gate IV index = PTR2IV(o->op_ppaddr);
6848*0Sstevel@tonic-gate SV* keysv;
6849*0Sstevel@tonic-gate HE* he;
6850*0Sstevel@tonic-gate
6851*0Sstevel@tonic-gate if (!PL_custom_op_descs)
6852*0Sstevel@tonic-gate return PL_op_desc[OP_CUSTOM];
6853*0Sstevel@tonic-gate
6854*0Sstevel@tonic-gate keysv = sv_2mortal(newSViv(index));
6855*0Sstevel@tonic-gate
6856*0Sstevel@tonic-gate he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
6857*0Sstevel@tonic-gate if (!he)
6858*0Sstevel@tonic-gate return PL_op_desc[OP_CUSTOM];
6859*0Sstevel@tonic-gate
6860*0Sstevel@tonic-gate return SvPV_nolen(HeVAL(he));
6861*0Sstevel@tonic-gate }
6862*0Sstevel@tonic-gate
6863*0Sstevel@tonic-gate
6864*0Sstevel@tonic-gate #include "XSUB.h"
6865*0Sstevel@tonic-gate
6866*0Sstevel@tonic-gate /* Efficient sub that returns a constant scalar value. */
6867*0Sstevel@tonic-gate static void
const_sv_xsub(pTHX_ CV * cv)6868*0Sstevel@tonic-gate const_sv_xsub(pTHX_ CV* cv)
6869*0Sstevel@tonic-gate {
6870*0Sstevel@tonic-gate dXSARGS;
6871*0Sstevel@tonic-gate if (items != 0) {
6872*0Sstevel@tonic-gate #if 0
6873*0Sstevel@tonic-gate Perl_croak(aTHX_ "usage: %s::%s()",
6874*0Sstevel@tonic-gate HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6875*0Sstevel@tonic-gate #endif
6876*0Sstevel@tonic-gate }
6877*0Sstevel@tonic-gate EXTEND(sp, 1);
6878*0Sstevel@tonic-gate ST(0) = (SV*)XSANY.any_ptr;
6879*0Sstevel@tonic-gate XSRETURN(1);
6880*0Sstevel@tonic-gate }
6881