This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pmruntime: make more use of Perl_re_op_compile
[perl5.git] / op.c
CommitLineData
4b88f280 1#line 2 "op.c"
a0d0e21e 2/* op.c
79072805 3 *
1129b882
NC
4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
79072805
LW
6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
a0d0e21e
LW
10 */
11
12/*
4ac71550
TC
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
18 *
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
79072805
LW
20 */
21
166f8a29
DM
22/* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
24 *
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
31 * stack.
32 *
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
37 *
38 * newBINOP(OP_ADD, flags,
39 * newSVREF($a),
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41 * )
42 *
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
45 */
ccfc67b7 46
61b743bb
DM
47/*
48Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50 A bottom-up pass
51 A top-down pass
52 An execution-order pass
53
54The bottom-up pass is represented by all the "newOP" routines and
55the ck_ routines. The bottom-upness is actually driven by yacc.
56So at the point that a ck_ routine fires, we have no idea what the
57context is, either upward in the syntax tree, or either forward or
58backward in the execution order. (The bottom-up parser builds that
59part of the execution order it knows about, but if you follow the "next"
60links around, you'll find it's actually a closed loop through the
ef9da979 61top level node.)
61b743bb
DM
62
63Whenever the bottom-up parser gets to a node that supplies context to
64its components, it invokes that portion of the top-down pass that applies
65to that part of the subtree (and marks the top node as processed, so
66if a node further up supplies context, it doesn't have to take the
67plunge again). As a particular subcase of this, as the new node is
68built, it takes all the closed execution loops of its subcomponents
69and links them into a new closed loop for the higher level node. But
70it's still not the real execution order.
71
72The actual execution order is not known till we get a grammar reduction
73to a top-level unit like a subroutine or file that will be called by
74"name" rather than via a "next" pointer. At that point, we can call
75into peep() to do that code's portion of the 3rd pass. It has to be
76recursive, but it's recursive on basic blocks, not on tree nodes.
77*/
78
06e0342d 79/* To implement user lexical pragmas, there needs to be a way at run time to
b3ca2e83
NC
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
06e0342d 87 leaf, ignoring any key you've already seen (placeholder or not), storing
b3ca2e83
NC
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
91
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
c28fe1ec 95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
34795b44 96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
c28fe1ec
NC
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
b3ca2e83
NC
99*/
100
79072805 101#include "EXTERN.h"
864dbfa3 102#define PERL_IN_OP_C
79072805 103#include "perl.h"
77ca0c92 104#include "keywords.h"
2846acbf 105#include "feature.h"
74529a43 106#include "regcomp.h"
79072805 107
16c91539 108#define CALL_PEEP(o) PL_peepp(aTHX_ o)
1a0a2ba9 109#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
16c91539 110#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
a2efc822 111
238a4c30
NIS
112#if defined(PL_OP_SLAB_ALLOC)
113
f1fac472
NC
114#ifdef PERL_DEBUG_READONLY_OPS
115# define PERL_SLAB_SIZE 4096
116# include <sys/mman.h>
117#endif
118
238a4c30
NIS
119#ifndef PERL_SLAB_SIZE
120#define PERL_SLAB_SIZE 2048
121#endif
122
c7e45529 123void *
e91d68d5 124Perl_Slab_Alloc(pTHX_ size_t sz)
1c846c1f 125{
5186cc12 126 dVAR;
5a8e194f
NIS
127 /*
128 * To make incrementing use count easy PL_OpSlab is an I32 *
129 * To make inserting the link to slab PL_OpPtr is I32 **
130 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
131 * Add an overhead for pointer to slab and round up as a number of pointers
132 */
133 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
238a4c30 134 if ((PL_OpSpace -= sz) < 0) {
f1fac472
NC
135#ifdef PERL_DEBUG_READONLY_OPS
136 /* We need to allocate chunk by chunk so that we can control the VM
137 mapping */
5186cc12 138 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
f1fac472
NC
139 MAP_ANON|MAP_PRIVATE, -1, 0);
140
141 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
142 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
143 PL_OpPtr));
144 if(PL_OpPtr == MAP_FAILED) {
145 perror("mmap failed");
146 abort();
147 }
148#else
277e868c
NC
149
150 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
f1fac472 151#endif
083fcd59 152 if (!PL_OpPtr) {
238a4c30
NIS
153 return NULL;
154 }
5a8e194f
NIS
155 /* We reserve the 0'th I32 sized chunk as a use count */
156 PL_OpSlab = (I32 *) PL_OpPtr;
157 /* Reduce size by the use count word, and by the size we need.
158 * Latter is to mimic the '-=' in the if() above
159 */
160 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
238a4c30
NIS
161 /* Allocation pointer starts at the top.
162 Theory: because we build leaves before trunk allocating at end
163 means that at run time access is cache friendly upward
164 */
5a8e194f 165 PL_OpPtr += PERL_SLAB_SIZE;
f1fac472
NC
166
167#ifdef PERL_DEBUG_READONLY_OPS
168 /* We remember this slab. */
169 /* This implementation isn't efficient, but it is simple. */
5186cc12 170 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
f1fac472
NC
171 PL_slabs[PL_slab_count++] = PL_OpSlab;
172 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
173#endif
238a4c30
NIS
174 }
175 assert( PL_OpSpace >= 0 );
176 /* Move the allocation pointer down */
177 PL_OpPtr -= sz;
5a8e194f 178 assert( PL_OpPtr > (I32 **) PL_OpSlab );
238a4c30
NIS
179 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
180 (*PL_OpSlab)++; /* Increment use count of slab */
5a8e194f 181 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
238a4c30
NIS
182 assert( *PL_OpSlab > 0 );
183 return (void *)(PL_OpPtr + 1);
184}
185
f1fac472
NC
186#ifdef PERL_DEBUG_READONLY_OPS
187void
188Perl_pending_Slabs_to_ro(pTHX) {
189 /* Turn all the allocated op slabs read only. */
190 U32 count = PL_slab_count;
191 I32 **const slabs = PL_slabs;
192
193 /* Reset the array of pending OP slabs, as we're about to turn this lot
194 read only. Also, do it ahead of the loop in case the warn triggers,
195 and a warn handler has an eval */
196
f1fac472
NC
197 PL_slabs = NULL;
198 PL_slab_count = 0;
199
200 /* Force a new slab for any further allocation. */
201 PL_OpSpace = 0;
202
203 while (count--) {
5892a4d4 204 void *const start = slabs[count];
f1fac472
NC
205 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
206 if(mprotect(start, size, PROT_READ)) {
207 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
208 start, (unsigned long) size, errno);
209 }
210 }
5892a4d4
NC
211
212 free(slabs);
f1fac472
NC
213}
214
215STATIC void
216S_Slab_to_rw(pTHX_ void *op)
217{
218 I32 * const * const ptr = (I32 **) op;
219 I32 * const slab = ptr[-1];
7918f24d
NC
220
221 PERL_ARGS_ASSERT_SLAB_TO_RW;
222
f1fac472
NC
223 assert( ptr-1 > (I32 **) slab );
224 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
225 assert( *slab > 0 );
226 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
227 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
228 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
229 }
230}
fc97af9c
NC
231
232OP *
233Perl_op_refcnt_inc(pTHX_ OP *o)
234{
235 if(o) {
236 Slab_to_rw(o);
237 ++o->op_targ;
238 }
239 return o;
240
241}
242
243PADOFFSET
244Perl_op_refcnt_dec(pTHX_ OP *o)
245{
7918f24d 246 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
fc97af9c
NC
247 Slab_to_rw(o);
248 return --o->op_targ;
249}
f1fac472
NC
250#else
251# define Slab_to_rw(op)
252#endif
253
c7e45529
AE
254void
255Perl_Slab_Free(pTHX_ void *op)
238a4c30 256{
551405c4 257 I32 * const * const ptr = (I32 **) op;
aec46f14 258 I32 * const slab = ptr[-1];
7918f24d 259 PERL_ARGS_ASSERT_SLAB_FREE;
5a8e194f
NIS
260 assert( ptr-1 > (I32 **) slab );
261 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
238a4c30 262 assert( *slab > 0 );
f1fac472 263 Slab_to_rw(op);
238a4c30 264 if (--(*slab) == 0) {
7e4e8c89
NC
265# ifdef NETWARE
266# define PerlMemShared PerlMem
267# endif
083fcd59 268
f1fac472 269#ifdef PERL_DEBUG_READONLY_OPS
782a40f1 270 U32 count = PL_slab_count;
f1fac472 271 /* Need to remove this slab from our list of slabs */
782a40f1 272 if (count) {
f1fac472
NC
273 while (count--) {
274 if (PL_slabs[count] == slab) {
5186cc12 275 dVAR;
f1fac472
NC
276 /* Found it. Move the entry at the end to overwrite it. */
277 DEBUG_m(PerlIO_printf(Perl_debug_log,
278 "Deallocate %p by moving %p from %lu to %lu\n",
279 PL_OpSlab,
280 PL_slabs[PL_slab_count - 1],
281 PL_slab_count, count));
282 PL_slabs[count] = PL_slabs[--PL_slab_count];
283 /* Could realloc smaller at this point, but probably not
284 worth it. */
fc97af9c
NC
285 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
286 perror("munmap failed");
287 abort();
288 }
289 break;
f1fac472 290 }
f1fac472
NC
291 }
292 }
293#else
083fcd59 294 PerlMemShared_free(slab);
f1fac472 295#endif
238a4c30
NIS
296 if (slab == PL_OpSlab) {
297 PL_OpSpace = 0;
298 }
299 }
b7dc083c 300}
b7dc083c 301#endif
e50aee73 302/*
ce6f1cbc 303 * In the following definition, the ", (OP*)0" is just to make the compiler
a5f75d66 304 * think the expression is of the right type: croak actually does a Siglongjmp.
e50aee73 305 */
11343788 306#define CHECKOP(type,o) \
ce6f1cbc 307 ((PL_op_mask && PL_op_mask[type]) \
5dc0d613 308 ? ( op_free((OP*)o), \
cb77fdf0 309 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
ce6f1cbc 310 (OP*)0 ) \
16c91539 311 : PL_check[type](aTHX_ (OP*)o))
e50aee73 312
e6438c1a 313#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
c53d7c7d 314
cba5a3b0
DG
315#define CHANGE_TYPE(o,type) \
316 STMT_START { \
317 o->op_type = (OPCODE)type; \
318 o->op_ppaddr = PL_ppaddr[type]; \
319 } STMT_END
320
ce16c625 321STATIC SV*
cea2e8a9 322S_gv_ename(pTHX_ GV *gv)
4633a7c4 323{
46c461b5 324 SV* const tmpsv = sv_newmortal();
7918f24d
NC
325
326 PERL_ARGS_ASSERT_GV_ENAME;
327
bd61b366 328 gv_efullname3(tmpsv, gv, NULL);
ce16c625 329 return tmpsv;
4633a7c4
LW
330}
331
76e3520e 332STATIC OP *
cea2e8a9 333S_no_fh_allowed(pTHX_ OP *o)
79072805 334{
7918f24d
NC
335 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
336
cea2e8a9 337 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
53e06cf0 338 OP_DESC(o)));
11343788 339 return o;
79072805
LW
340}
341
76e3520e 342STATIC OP *
ce16c625 343S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 344{
ce16c625
BF
345 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
346 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
347 SvUTF8(namesv) | flags);
348 return o;
349}
350
351STATIC OP *
352S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
353{
354 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
355 yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
356 return o;
357}
358
359STATIC OP *
360S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
361{
362 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
7918f24d 363
ce16c625 364 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
11343788 365 return o;
79072805
LW
366}
367
76e3520e 368STATIC OP *
ce16c625 369S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
79072805 370{
ce16c625 371 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
7918f24d 372
ce16c625
BF
373 yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
374 SvUTF8(namesv) | flags);
11343788 375 return o;
79072805
LW
376}
377
76e3520e 378STATIC void
ce16c625 379S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
8990e307 380{
ce16c625
BF
381 PERL_ARGS_ASSERT_BAD_TYPE_PV;
382
383 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
384 (int)n, name, t, OP_DESC(kid)), flags);
385}
7918f24d 386
ce16c625
BF
387STATIC void
388S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
389{
390 PERL_ARGS_ASSERT_BAD_TYPE_SV;
391
392 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
393 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
8990e307
LW
394}
395
7a52d87a 396STATIC void
eb796c7f 397S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 398{
7918f24d
NC
399 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
400
eb8433b7
NC
401 if (PL_madskills)
402 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 403 qerror(Perl_mess(aTHX_
35c1215d 404 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 405 SVfARG(cSVOPo_sv)));
eb796c7f 406 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS
407}
408
79072805
LW
409/* "register" allocation */
410
411PADOFFSET
d6447115 412Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 413{
97aff369 414 dVAR;
a0d0e21e 415 PADOFFSET off;
12bd6ede 416 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 417
7918f24d
NC
418 PERL_ARGS_ASSERT_ALLOCMY;
419
48d0d1be 420 if (flags & ~SVf_UTF8)
d6447115
NC
421 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
422 (UV)flags);
423
424 /* Until we're using the length for real, cross check that we're being
425 told the truth. */
426 assert(strlen(name) == len);
427
59f00321 428 /* complain about "my $<special_var>" etc etc */
d6447115 429 if (len &&
3edf23ff 430 !(is_our ||
155aba94 431 isALPHA(name[1]) ||
b14845b4 432 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
d6447115 433 (name[1] == '_' && (*name == '$' || len > 2))))
834a4ddd 434 {
6b58708b 435 /* name[2] is true if strlen(name) > 2 */
b14845b4
FC
436 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
437 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
d6447115
NC
438 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
439 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 440 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 441 } else {
ce16c625
BF
442 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
443 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
46fc3d4c 444 }
a0d0e21e 445 }
748a9306 446
dd2155a4 447 /* allocate a spare slot and store the name in that slot */
93a17b20 448
cc76b5cc 449 off = pad_add_name_pvn(name, len,
48d0d1be
BF
450 (is_our ? padadd_OUR :
451 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
452 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
12bd6ede 453 PL_parser->in_my_stash,
3edf23ff 454 (is_our
133706a6
RGS
455 /* $_ is always in main::, even with our */
456 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 457 : NULL
cca43f78 458 )
dd2155a4 459 );
a74073ad
DM
460 /* anon sub prototypes contains state vars should always be cloned,
461 * otherwise the state var would be shared between anon subs */
462
463 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
464 CvCLONE_on(PL_compcv);
465
dd2155a4 466 return off;
79072805
LW
467}
468
c0b8aebd
FC
469/*
470=for apidoc alloccopstash
471
472Available only under threaded builds, this function allocates an entry in
473C<PL_stashpad> for the stash passed to it.
474
475=cut
476*/
477
d4d03940
FC
478#ifdef USE_ITHREADS
479PADOFFSET
480Perl_alloccopstash(pTHX_ HV *hv)
481{
482 PADOFFSET off = 0, o = 1;
483 bool found_slot = FALSE;
484
485 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
486
487 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
488
489 for (; o < PL_stashpadmax; ++o) {
490 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
491 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
492 found_slot = TRUE, off = o;
493 }
494 if (!found_slot) {
495 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
496 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
497 off = PL_stashpadmax;
498 PL_stashpadmax += 10;
499 }
500
501 PL_stashpad[PL_stashpadix = off] = hv;
502 return off;
503}
504#endif
505
d2c837a0
DM
506/* free the body of an op without examining its contents.
507 * Always use this rather than FreeOp directly */
508
4136a0f7 509static void
d2c837a0
DM
510S_op_destroy(pTHX_ OP *o)
511{
512 if (o->op_latefree) {
513 o->op_latefreed = 1;
514 return;
515 }
516 FreeOp(o);
517}
518
c4bd3ae5
NC
519#ifdef USE_ITHREADS
520# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
521#else
522# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
523#endif
d2c837a0 524
79072805
LW
525/* Destructor */
526
527void
864dbfa3 528Perl_op_free(pTHX_ OP *o)
79072805 529{
27da23d5 530 dVAR;
acb36ea4 531 OPCODE type;
79072805 532
85594c31 533 if (!o)
79072805 534 return;
670f3923
DM
535 if (o->op_latefreed) {
536 if (o->op_latefree)
537 return;
538 goto do_free;
539 }
79072805 540
67566ccd 541 type = o->op_type;
7934575e 542 if (o->op_private & OPpREFCOUNTED) {
67566ccd 543 switch (type) {
7934575e
GS
544 case OP_LEAVESUB:
545 case OP_LEAVESUBLV:
546 case OP_LEAVEEVAL:
547 case OP_LEAVE:
548 case OP_SCOPE:
549 case OP_LEAVEWRITE:
67566ccd
AL
550 {
551 PADOFFSET refcnt;
7934575e 552 OP_REFCNT_LOCK;
4026c95a 553 refcnt = OpREFCNT_dec(o);
7934575e 554 OP_REFCNT_UNLOCK;
bfd0ff22
NC
555 if (refcnt) {
556 /* Need to find and remove any pattern match ops from the list
557 we maintain for reset(). */
558 find_and_forget_pmops(o);
4026c95a 559 return;
67566ccd 560 }
bfd0ff22 561 }
7934575e
GS
562 break;
563 default:
564 break;
565 }
566 }
567
f37b8c3f
VP
568 /* Call the op_free hook if it has been set. Do it now so that it's called
569 * at the right time for refcounted ops, but still before all of the kids
570 * are freed. */
571 CALL_OPFREEHOOK(o);
572
11343788 573 if (o->op_flags & OPf_KIDS) {
6867be6d 574 register OP *kid, *nextkid;
11343788 575 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 576 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 577 op_free(kid);
85e6fe83 578 }
79072805 579 }
acb36ea4 580
fc97af9c
NC
581#ifdef PERL_DEBUG_READONLY_OPS
582 Slab_to_rw(o);
583#endif
584
acb36ea4
GS
585 /* COP* is not cleared by op_clear() so that we may track line
586 * numbers etc even after null() */
cc93af5f
RGS
587 if (type == OP_NEXTSTATE || type == OP_DBSTATE
588 || (type == OP_NULL /* the COP might have been null'ed */
589 && ((OPCODE)o->op_targ == OP_NEXTSTATE
590 || (OPCODE)o->op_targ == OP_DBSTATE))) {
acb36ea4 591 cop_free((COP*)o);
3235b7a3 592 }
acb36ea4 593
c53f1caa
RU
594 if (type == OP_NULL)
595 type = (OPCODE)o->op_targ;
596
acb36ea4 597 op_clear(o);
670f3923
DM
598 if (o->op_latefree) {
599 o->op_latefreed = 1;
600 return;
601 }
602 do_free:
238a4c30 603 FreeOp(o);
4d494880
DM
604#ifdef DEBUG_LEAKING_SCALARS
605 if (PL_op == o)
5f66b61c 606 PL_op = NULL;
4d494880 607#endif
acb36ea4 608}
79072805 609
93c66552
DM
610void
611Perl_op_clear(pTHX_ OP *o)
acb36ea4 612{
13137afc 613
27da23d5 614 dVAR;
7918f24d
NC
615
616 PERL_ARGS_ASSERT_OP_CLEAR;
617
eb8433b7 618#ifdef PERL_MAD
df31c78c
NC
619 mad_free(o->op_madprop);
620 o->op_madprop = 0;
eb8433b7
NC
621#endif
622
623 retry:
11343788 624 switch (o->op_type) {
acb36ea4 625 case OP_NULL: /* Was holding old type, if any. */
eb8433b7 626 if (PL_madskills && o->op_targ != OP_NULL) {
61a59f30 627 o->op_type = (Optype)o->op_targ;
eb8433b7
NC
628 o->op_targ = 0;
629 goto retry;
630 }
4d193d44 631 case OP_ENTERTRY:
acb36ea4 632 case OP_ENTEREVAL: /* Was holding hints. */
acb36ea4 633 o->op_targ = 0;
a0d0e21e 634 break;
a6006777 635 default:
ac4c12e7 636 if (!(o->op_flags & OPf_REF)
ef69c8fc 637 || (PL_check[o->op_type] != Perl_ck_ftst))
a6006777 638 break;
639 /* FALL THROUGH */
463ee0b2 640 case OP_GVSV:
79072805 641 case OP_GV:
a6006777 642 case OP_AELEMFAST:
93bad3fd 643 {
f7461760
Z
644 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
645#ifdef USE_ITHREADS
646 && PL_curpad
647#endif
648 ? cGVOPo_gv : NULL;
b327b36f
NC
649 /* It's possible during global destruction that the GV is freed
650 before the optree. Whilst the SvREFCNT_inc is happy to bump from
651 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
652 will trigger an assertion failure, because the entry to sv_clear
653 checks that the scalar is not already freed. A check of for
654 !SvIS_FREED(gv) turns out to be invalid, because during global
655 destruction the reference count can be forced down to zero
656 (with SVf_BREAK set). In which case raising to 1 and then
657 dropping to 0 triggers cleanup before it should happen. I
658 *think* that this might actually be a general, systematic,
659 weakness of the whole idea of SVf_BREAK, in that code *is*
660 allowed to raise and lower references during global destruction,
661 so any *valid* code that happens to do this during global
662 destruction might well trigger premature cleanup. */
663 bool still_valid = gv && SvREFCNT(gv);
664
665 if (still_valid)
666 SvREFCNT_inc_simple_void(gv);
350de78d 667#ifdef USE_ITHREADS
6a077020
DM
668 if (cPADOPo->op_padix > 0) {
669 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
670 * may still exist on the pad */
671 pad_swipe(cPADOPo->op_padix, TRUE);
672 cPADOPo->op_padix = 0;
673 }
350de78d 674#else
6a077020 675 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 676 cSVOPo->op_sv = NULL;
350de78d 677#endif
b327b36f 678 if (still_valid) {
f7461760
Z
679 int try_downgrade = SvREFCNT(gv) == 2;
680 SvREFCNT_dec(gv);
681 if (try_downgrade)
682 gv_try_downgrade(gv);
683 }
6a077020 684 }
79072805 685 break;
a1ae71d2 686 case OP_METHOD_NAMED:
79072805 687 case OP_CONST:
996c9baa 688 case OP_HINTSEVAL:
11343788 689 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 690 cSVOPo->op_sv = NULL;
3b1c21fa
AB
691#ifdef USE_ITHREADS
692 /** Bug #15654
693 Even if op_clear does a pad_free for the target of the op,
6a077020 694 pad_free doesn't actually remove the sv that exists in the pad;
3b1c21fa
AB
695 instead it lives on. This results in that it could be reused as
696 a target later on when the pad was reallocated.
697 **/
698 if(o->op_targ) {
699 pad_swipe(o->op_targ,1);
700 o->op_targ = 0;
701 }
702#endif
79072805 703 break;
748a9306
LW
704 case OP_GOTO:
705 case OP_NEXT:
706 case OP_LAST:
707 case OP_REDO:
11343788 708 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
748a9306
LW
709 break;
710 /* FALL THROUGH */
a0d0e21e 711 case OP_TRANS:
bb16bae8 712 case OP_TRANSR:
acb36ea4 713 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
043e41b8
DM
714#ifdef USE_ITHREADS
715 if (cPADOPo->op_padix > 0) {
716 pad_swipe(cPADOPo->op_padix, TRUE);
717 cPADOPo->op_padix = 0;
718 }
719#else
a0ed51b3 720 SvREFCNT_dec(cSVOPo->op_sv);
a0714e2c 721 cSVOPo->op_sv = NULL;
043e41b8 722#endif
acb36ea4
GS
723 }
724 else {
ea71c68d 725 PerlMemShared_free(cPVOPo->op_pv);
bd61b366 726 cPVOPo->op_pv = NULL;
acb36ea4 727 }
a0d0e21e
LW
728 break;
729 case OP_SUBST:
20e98b0f 730 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
971a9dd3 731 goto clear_pmop;
748a9306 732 case OP_PUSHRE:
971a9dd3 733#ifdef USE_ITHREADS
20e98b0f 734 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
dd2155a4
DM
735 /* No GvIN_PAD_off here, because other references may still
736 * exist on the pad */
20e98b0f 737 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
971a9dd3
GS
738 }
739#else
ad64d0ec 740 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
971a9dd3
GS
741#endif
742 /* FALL THROUGH */
a0d0e21e 743 case OP_MATCH:
8782bef2 744 case OP_QR:
971a9dd3 745clear_pmop:
867940b8
DM
746 if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
747 op_free(cPMOPo->op_code_list);
68e2671b 748 cPMOPo->op_code_list = NULL;
c2b1997a 749 forget_pmop(cPMOPo, 1);
20e98b0f 750 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
9cddf794
NC
751 /* we use the same protection as the "SAFE" version of the PM_ macros
752 * here since sv_clean_all might release some PMOPs
5f8cb046
DM
753 * after PL_regex_padav has been cleared
754 * and the clearing of PL_regex_padav needs to
755 * happen before sv_clean_all
756 */
13137afc
AB
757#ifdef USE_ITHREADS
758 if(PL_regex_pad) { /* We could be in destruction */
402d2eb1 759 const IV offset = (cPMOPo)->op_pmoffset;
9cddf794 760 ReREFCNT_dec(PM_GETRE(cPMOPo));
402d2eb1
NC
761 PL_regex_pad[offset] = &PL_sv_undef;
762 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
763 sizeof(offset));
13137afc 764 }
9cddf794
NC
765#else
766 ReREFCNT_dec(PM_GETRE(cPMOPo));
767 PM_SETRE(cPMOPo, NULL);
1eb1540c 768#endif
13137afc 769
a0d0e21e 770 break;
79072805
LW
771 }
772
743e66e6 773 if (o->op_targ > 0) {
11343788 774 pad_free(o->op_targ);
743e66e6
GS
775 o->op_targ = 0;
776 }
79072805
LW
777}
778
76e3520e 779STATIC void
3eb57f73
HS
780S_cop_free(pTHX_ COP* cop)
781{
7918f24d
NC
782 PERL_ARGS_ASSERT_COP_FREE;
783
05ec9bb3 784 CopFILE_free(cop);
0453d815 785 if (! specialWARN(cop->cop_warnings))
72dc9ed5 786 PerlMemShared_free(cop->cop_warnings);
20439bc7 787 cophh_free(CopHINTHASH_get(cop));
3eb57f73
HS
788}
789
c2b1997a 790STATIC void
c4bd3ae5
NC
791S_forget_pmop(pTHX_ PMOP *const o
792#ifdef USE_ITHREADS
793 , U32 flags
794#endif
795 )
c2b1997a
NC
796{
797 HV * const pmstash = PmopSTASH(o);
7918f24d
NC
798
799 PERL_ARGS_ASSERT_FORGET_PMOP;
800
e39a6381 801 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 802 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC
803 if (mg) {
804 PMOP **const array = (PMOP**) mg->mg_ptr;
805 U32 count = mg->mg_len / sizeof(PMOP**);
806 U32 i = count;
807
808 while (i--) {
809 if (array[i] == o) {
810 /* Found it. Move the entry at the end to overwrite it. */
811 array[i] = array[--count];
812 mg->mg_len = count * sizeof(PMOP**);
813 /* Could realloc smaller at this point always, but probably
814 not worth it. Probably worth free()ing if we're the
815 last. */
816 if(!count) {
817 Safefree(mg->mg_ptr);
818 mg->mg_ptr = NULL;
819 }
820 break;
821 }
822 }
823 }
824 }
1cdf7faf
NC
825 if (PL_curpm == o)
826 PL_curpm = NULL;
c4bd3ae5 827#ifdef USE_ITHREADS
c2b1997a
NC
828 if (flags)
829 PmopSTASH_free(o);
c4bd3ae5 830#endif
c2b1997a
NC
831}
832
bfd0ff22
NC
833STATIC void
834S_find_and_forget_pmops(pTHX_ OP *o)
835{
7918f24d
NC
836 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
837
bfd0ff22
NC
838 if (o->op_flags & OPf_KIDS) {
839 OP *kid = cUNOPo->op_first;
840 while (kid) {
841 switch (kid->op_type) {
842 case OP_SUBST:
843 case OP_PUSHRE:
844 case OP_MATCH:
845 case OP_QR:
846 forget_pmop((PMOP*)kid, 0);
847 }
848 find_and_forget_pmops(kid);
849 kid = kid->op_sibling;
850 }
851 }
852}
853
93c66552
DM
854void
855Perl_op_null(pTHX_ OP *o)
8990e307 856{
27da23d5 857 dVAR;
7918f24d
NC
858
859 PERL_ARGS_ASSERT_OP_NULL;
860
acb36ea4
GS
861 if (o->op_type == OP_NULL)
862 return;
eb8433b7
NC
863 if (!PL_madskills)
864 op_clear(o);
11343788
MB
865 o->op_targ = o->op_type;
866 o->op_type = OP_NULL;
22c35a8c 867 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW
868}
869
4026c95a
SH
870void
871Perl_op_refcnt_lock(pTHX)
872{
27da23d5 873 dVAR;
96a5add6 874 PERL_UNUSED_CONTEXT;
4026c95a
SH
875 OP_REFCNT_LOCK;
876}
877
878void
879Perl_op_refcnt_unlock(pTHX)
880{
27da23d5 881 dVAR;
96a5add6 882 PERL_UNUSED_CONTEXT;
4026c95a
SH
883 OP_REFCNT_UNLOCK;
884}
885
79072805
LW
886/* Contextualizers */
887
d9088386
Z
888/*
889=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
890
891Applies a syntactic context to an op tree representing an expression.
892I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
893or C<G_VOID> to specify the context to apply. The modified op tree
894is returned.
895
896=cut
897*/
898
899OP *
900Perl_op_contextualize(pTHX_ OP *o, I32 context)
901{
902 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
903 switch (context) {
904 case G_SCALAR: return scalar(o);
905 case G_ARRAY: return list(o);
906 case G_VOID: return scalarvoid(o);
907 default:
5637ef5b
NC
908 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
909 (long) context);
d9088386
Z
910 return o;
911 }
912}
913
5983a79d
BM
914/*
915=head1 Optree Manipulation Functions
79072805 916
5983a79d
BM
917=for apidoc Am|OP*|op_linklist|OP *o
918This function is the implementation of the L</LINKLIST> macro. It should
919not be called directly.
920
921=cut
922*/
923
924OP *
925Perl_op_linklist(pTHX_ OP *o)
79072805 926{
3edf23ff 927 OP *first;
79072805 928
5983a79d 929 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 930
11343788
MB
931 if (o->op_next)
932 return o->op_next;
79072805
LW
933
934 /* establish postfix order */
3edf23ff
AL
935 first = cUNOPo->op_first;
936 if (first) {
6867be6d 937 register OP *kid;
3edf23ff
AL
938 o->op_next = LINKLIST(first);
939 kid = first;
940 for (;;) {
941 if (kid->op_sibling) {
79072805 942 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL
943 kid = kid->op_sibling;
944 } else {
11343788 945 kid->op_next = o;
3edf23ff
AL
946 break;
947 }
79072805
LW
948 }
949 }
950 else
11343788 951 o->op_next = o;
79072805 952
11343788 953 return o->op_next;
79072805
LW
954}
955
1f676739 956static OP *
2dd5337b 957S_scalarkids(pTHX_ OP *o)
79072805 958{
11343788 959 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 960 OP *kid;
11343788 961 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
962 scalar(kid);
963 }
11343788 964 return o;
79072805
LW
965}
966
76e3520e 967STATIC OP *
cea2e8a9 968S_scalarboolean(pTHX_ OP *o)
8990e307 969{
97aff369 970 dVAR;
7918f24d
NC
971
972 PERL_ARGS_ASSERT_SCALARBOOLEAN;
973
6b7c6d95
FC
974 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
975 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
d008e5eb 976 if (ckWARN(WARN_SYNTAX)) {
6867be6d 977 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 978
53a7735b
DM
979 if (PL_parser && PL_parser->copline != NOLINE)
980 CopLINE_set(PL_curcop, PL_parser->copline);
9014280d 981 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 982 CopLINE_set(PL_curcop, oldline);
d008e5eb 983 }
a0d0e21e 984 }
11343788 985 return scalar(o);
8990e307
LW
986}
987
988OP *
864dbfa3 989Perl_scalar(pTHX_ OP *o)
79072805 990{
27da23d5 991 dVAR;
79072805
LW
992 OP *kid;
993
a0d0e21e 994 /* assumes no premature commitment */
13765c85
DM
995 if (!o || (PL_parser && PL_parser->error_count)
996 || (o->op_flags & OPf_WANT)
5dc0d613 997 || o->op_type == OP_RETURN)
7e363e51 998 {
11343788 999 return o;
7e363e51 1000 }
79072805 1001
5dc0d613 1002 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1003
11343788 1004 switch (o->op_type) {
79072805 1005 case OP_REPEAT:
11343788 1006 scalar(cBINOPo->op_first);
8990e307 1007 break;
79072805
LW
1008 case OP_OR:
1009 case OP_AND:
1010 case OP_COND_EXPR:
11343788 1011 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 1012 scalar(kid);
79072805 1013 break;
a0d0e21e 1014 /* FALL THROUGH */
a6d8037e 1015 case OP_SPLIT:
79072805 1016 case OP_MATCH:
8782bef2 1017 case OP_QR:
79072805
LW
1018 case OP_SUBST:
1019 case OP_NULL:
8990e307 1020 default:
11343788
MB
1021 if (o->op_flags & OPf_KIDS) {
1022 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW
1023 scalar(kid);
1024 }
79072805
LW
1025 break;
1026 case OP_LEAVE:
1027 case OP_LEAVETRY:
5dc0d613 1028 kid = cLISTOPo->op_first;
54310121 1029 scalar(kid);
25b991bf
VP
1030 kid = kid->op_sibling;
1031 do_kids:
1032 while (kid) {
1033 OP *sib = kid->op_sibling;
c08f093b
VP
1034 if (sib && kid->op_type != OP_LEAVEWHEN)
1035 scalarvoid(kid);
1036 else
54310121 1037 scalar(kid);
25b991bf 1038 kid = sib;
54310121 1039 }
11206fdd 1040 PL_curcop = &PL_compiling;
54310121 1041 break;
748a9306 1042 case OP_SCOPE:
79072805 1043 case OP_LINESEQ:
8990e307 1044 case OP_LIST:
25b991bf
VP
1045 kid = cLISTOPo->op_first;
1046 goto do_kids;
a801c63c 1047 case OP_SORT:
a2a5de95 1048 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1049 break;
79072805 1050 }
11343788 1051 return o;
79072805
LW
1052}
1053
1054OP *
864dbfa3 1055Perl_scalarvoid(pTHX_ OP *o)
79072805 1056{
27da23d5 1057 dVAR;
79072805 1058 OP *kid;
c445ea15 1059 const char* useless = NULL;
34ee6772 1060 U32 useless_is_utf8 = 0;
8990e307 1061 SV* sv;
2ebea0a1
GS
1062 U8 want;
1063
7918f24d
NC
1064 PERL_ARGS_ASSERT_SCALARVOID;
1065
eb8433b7
NC
1066 /* trailing mad null ops don't count as "there" for void processing */
1067 if (PL_madskills &&
1068 o->op_type != OP_NULL &&
1069 o->op_sibling &&
1070 o->op_sibling->op_type == OP_NULL)
1071 {
1072 OP *sib;
1073 for (sib = o->op_sibling;
1074 sib && sib->op_type == OP_NULL;
1075 sib = sib->op_sibling) ;
1076
1077 if (!sib)
1078 return o;
1079 }
1080
acb36ea4 1081 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS
1082 || o->op_type == OP_DBSTATE
1083 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1084 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1085 PL_curcop = (COP*)o; /* for warning below */
79072805 1086
54310121 1087 /* assumes no premature commitment */
2ebea0a1 1088 want = o->op_flags & OPf_WANT;
13765c85
DM
1089 if ((want && want != OPf_WANT_SCALAR)
1090 || (PL_parser && PL_parser->error_count)
25b991bf 1091 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1092 {
11343788 1093 return o;
7e363e51 1094 }
79072805 1095
b162f9ea 1096 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1097 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1098 {
b162f9ea 1099 return scalar(o); /* As if inside SASSIGN */
7e363e51 1100 }
1c846c1f 1101
5dc0d613 1102 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1103
11343788 1104 switch (o->op_type) {
79072805 1105 default:
22c35a8c 1106 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1107 break;
36477c24 1108 /* FALL THROUGH */
1109 case OP_REPEAT:
11343788 1110 if (o->op_flags & OPf_STACKED)
8990e307 1111 break;
5d82c453
GA
1112 goto func_ops;
1113 case OP_SUBSTR:
1114 if (o->op_private == 4)
1115 break;
8990e307
LW
1116 /* FALL THROUGH */
1117 case OP_GVSV:
1118 case OP_WANTARRAY:
1119 case OP_GV:
74295f0b 1120 case OP_SMARTMATCH:
8990e307
LW
1121 case OP_PADSV:
1122 case OP_PADAV:
1123 case OP_PADHV:
1124 case OP_PADANY:
1125 case OP_AV2ARYLEN:
8990e307 1126 case OP_REF:
a0d0e21e
LW
1127 case OP_REFGEN:
1128 case OP_SREFGEN:
8990e307
LW
1129 case OP_DEFINED:
1130 case OP_HEX:
1131 case OP_OCT:
1132 case OP_LENGTH:
8990e307
LW
1133 case OP_VEC:
1134 case OP_INDEX:
1135 case OP_RINDEX:
1136 case OP_SPRINTF:
1137 case OP_AELEM:
1138 case OP_AELEMFAST:
93bad3fd 1139 case OP_AELEMFAST_LEX:
8990e307 1140 case OP_ASLICE:
8990e307
LW
1141 case OP_HELEM:
1142 case OP_HSLICE:
1143 case OP_UNPACK:
1144 case OP_PACK:
8990e307
LW
1145 case OP_JOIN:
1146 case OP_LSLICE:
1147 case OP_ANONLIST:
1148 case OP_ANONHASH:
1149 case OP_SORT:
1150 case OP_REVERSE:
1151 case OP_RANGE:
1152 case OP_FLIP:
1153 case OP_FLOP:
1154 case OP_CALLER:
1155 case OP_FILENO:
1156 case OP_EOF:
1157 case OP_TELL:
1158 case OP_GETSOCKNAME:
1159 case OP_GETPEERNAME:
1160 case OP_READLINK:
1161 case OP_TELLDIR:
1162 case OP_GETPPID:
1163 case OP_GETPGRP:
1164 case OP_GETPRIORITY:
1165 case OP_TIME:
1166 case OP_TMS:
1167 case OP_LOCALTIME:
1168 case OP_GMTIME:
1169 case OP_GHBYNAME:
1170 case OP_GHBYADDR:
1171 case OP_GHOSTENT:
1172 case OP_GNBYNAME:
1173 case OP_GNBYADDR:
1174 case OP_GNETENT:
1175 case OP_GPBYNAME:
1176 case OP_GPBYNUMBER:
1177 case OP_GPROTOENT:
1178 case OP_GSBYNAME:
1179 case OP_GSBYPORT:
1180 case OP_GSERVENT:
1181 case OP_GPWNAM:
1182 case OP_GPWUID:
1183 case OP_GGRNAM:
1184 case OP_GGRGID:
1185 case OP_GETLOGIN:
78e1b766 1186 case OP_PROTOTYPE:
703227f5 1187 case OP_RUNCV:
5d82c453 1188 func_ops:
64aac5a9 1189 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1190 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1191 useless = OP_DESC(o);
75068674
RGS
1192 break;
1193
1194 case OP_SPLIT:
1195 kid = cLISTOPo->op_first;
1196 if (kid && kid->op_type == OP_PUSHRE
1197#ifdef USE_ITHREADS
1198 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1199#else
1200 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1201#endif
1202 useless = OP_DESC(o);
8990e307
LW
1203 break;
1204
9f82cd5f
YST
1205 case OP_NOT:
1206 kid = cUNOPo->op_first;
1207 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1208 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST
1209 goto func_ops;
1210 }
1211 useless = "negative pattern binding (!~)";
1212 break;
1213
4f4d7508
DC
1214 case OP_SUBST:
1215 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1216 useless = "non-destructive substitution (s///r)";
4f4d7508
DC
1217 break;
1218
bb16bae8
FC
1219 case OP_TRANSR:
1220 useless = "non-destructive transliteration (tr///r)";
1221 break;
1222
8990e307
LW
1223 case OP_RV2GV:
1224 case OP_RV2SV:
1225 case OP_RV2AV:
1226 case OP_RV2HV:
192587c2 1227 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1228 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW
1229 useless = "a variable";
1230 break;
79072805
LW
1231
1232 case OP_CONST:
7766f137 1233 sv = cSVOPo_sv;
7a52d87a
GS
1234 if (cSVOPo->op_private & OPpCONST_STRICT)
1235 no_bareword_allowed(o);
1236 else {
d008e5eb 1237 if (ckWARN(WARN_VOID)) {
e7fec78e 1238 /* don't warn on optimised away booleans, eg
b5a930ec 1239 * use constant Foo, 5; Foo || print; */
e7fec78e 1240 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1241 useless = NULL;
960b4253
MG
1242 /* the constants 0 and 1 are permitted as they are
1243 conventionally used as dummies in constructs like
1244 1 while some_condition_with_side_effects; */
e7fec78e 1245 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1246 useless = NULL;
d008e5eb 1247 else if (SvPOK(sv)) {
a52fe3ac
A
1248 /* perl4's way of mixing documentation and code
1249 (before the invention of POD) was based on a
1250 trick to mix nroff and perl code. The trick was
1251 built upon these three nroff macros being used in
1252 void context. The pink camel has the details in
1253 the script wrapman near page 319. */
6136c704
AL
1254 const char * const maybe_macro = SvPVX_const(sv);
1255 if (strnEQ(maybe_macro, "di", 2) ||
1256 strnEQ(maybe_macro, "ds", 2) ||
1257 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 1258 useless = NULL;
919f76a3 1259 else {
d3bcd21f 1260 SV * const dsv = newSVpvs("");
919f76a3
RGS
1261 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1262 "a constant (%s)",
1263 pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
1264 PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
1265 SvREFCNT_dec(dsv);
1266 useless = SvPV_nolen(msv);
1267 useless_is_utf8 = SvUTF8(msv);
1268 }
d008e5eb 1269 }
919f76a3
RGS
1270 else if (SvOK(sv)) {
1271 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1272 "a constant (%"SVf")", sv));
1273 useless = SvPV_nolen(msv);
1274 }
1275 else
1276 useless = "a constant (undef)";
8990e307
LW
1277 }
1278 }
93c66552 1279 op_null(o); /* don't execute or even remember it */
79072805
LW
1280 break;
1281
1282 case OP_POSTINC:
11343788 1283 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1284 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW
1285 break;
1286
1287 case OP_POSTDEC:
11343788 1288 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1289 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW
1290 break;
1291
679d6c4e
HS
1292 case OP_I_POSTINC:
1293 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1294 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1295 break;
1296
1297 case OP_I_POSTDEC:
1298 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1299 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1300 break;
1301
f2f8fd84
GG
1302 case OP_SASSIGN: {
1303 OP *rv2gv;
1304 UNOP *refgen, *rv2cv;
1305 LISTOP *exlist;
1306
1307 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1308 break;
1309
1310 rv2gv = ((BINOP *)o)->op_last;
1311 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1312 break;
1313
1314 refgen = (UNOP *)((BINOP *)o)->op_first;
1315
1316 if (!refgen || refgen->op_type != OP_REFGEN)
1317 break;
1318
1319 exlist = (LISTOP *)refgen->op_first;
1320 if (!exlist || exlist->op_type != OP_NULL
1321 || exlist->op_targ != OP_LIST)
1322 break;
1323
1324 if (exlist->op_first->op_type != OP_PUSHMARK)
1325 break;
1326
1327 rv2cv = (UNOP*)exlist->op_last;
1328
1329 if (rv2cv->op_type != OP_RV2CV)
1330 break;
1331
1332 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1333 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1334 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1335
1336 o->op_private |= OPpASSIGN_CV_TO_GV;
1337 rv2gv->op_private |= OPpDONT_INIT_GV;
1338 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1339
1340 break;
1341 }
1342
540dd770
GG
1343 case OP_AASSIGN: {
1344 inplace_aassign(o);
1345 break;
1346 }
1347
79072805
LW
1348 case OP_OR:
1349 case OP_AND:
edbe35ea
VP
1350 kid = cLOGOPo->op_first;
1351 if (kid->op_type == OP_NOT
1352 && (kid->op_flags & OPf_KIDS)
1353 && !PL_madskills) {
1354 if (o->op_type == OP_AND) {
1355 o->op_type = OP_OR;
1356 o->op_ppaddr = PL_ppaddr[OP_OR];
1357 } else {
1358 o->op_type = OP_AND;
1359 o->op_ppaddr = PL_ppaddr[OP_AND];
1360 }
1361 op_null(kid);
1362 }
1363
c963b151 1364 case OP_DOR:
79072805 1365 case OP_COND_EXPR:
0d863452
RH
1366 case OP_ENTERGIVEN:
1367 case OP_ENTERWHEN:
11343788 1368 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1369 scalarvoid(kid);
1370 break;
5aabfad6 1371
a0d0e21e 1372 case OP_NULL:
11343788 1373 if (o->op_flags & OPf_STACKED)
a0d0e21e 1374 break;
5aabfad6 1375 /* FALL THROUGH */
2ebea0a1
GS
1376 case OP_NEXTSTATE:
1377 case OP_DBSTATE:
79072805
LW
1378 case OP_ENTERTRY:
1379 case OP_ENTER:
11343788 1380 if (!(o->op_flags & OPf_KIDS))
79072805 1381 break;
54310121 1382 /* FALL THROUGH */
463ee0b2 1383 case OP_SCOPE:
79072805
LW
1384 case OP_LEAVE:
1385 case OP_LEAVETRY:
a0d0e21e 1386 case OP_LEAVELOOP:
79072805 1387 case OP_LINESEQ:
79072805 1388 case OP_LIST:
0d863452
RH
1389 case OP_LEAVEGIVEN:
1390 case OP_LEAVEWHEN:
11343788 1391 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1392 scalarvoid(kid);
1393 break;
c90c0ff4 1394 case OP_ENTEREVAL:
5196be3e 1395 scalarkids(o);
c90c0ff4 1396 break;
d6483035 1397 case OP_SCALAR:
5196be3e 1398 return scalar(o);
79072805 1399 }
a2a5de95 1400 if (useless)
34ee6772
BF
1401 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
1402 newSVpvn_flags(useless, strlen(useless),
1403 SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
11343788 1404 return o;
79072805
LW
1405}
1406
1f676739 1407static OP *
412da003 1408S_listkids(pTHX_ OP *o)
79072805 1409{
11343788 1410 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1411 OP *kid;
11343788 1412 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1413 list(kid);
1414 }
11343788 1415 return o;
79072805
LW
1416}
1417
1418OP *
864dbfa3 1419Perl_list(pTHX_ OP *o)
79072805 1420{
27da23d5 1421 dVAR;
79072805
LW
1422 OP *kid;
1423
a0d0e21e 1424 /* assumes no premature commitment */
13765c85
DM
1425 if (!o || (o->op_flags & OPf_WANT)
1426 || (PL_parser && PL_parser->error_count)
5dc0d613 1427 || o->op_type == OP_RETURN)
7e363e51 1428 {
11343788 1429 return o;
7e363e51 1430 }
79072805 1431
b162f9ea 1432 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1433 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1434 {
b162f9ea 1435 return o; /* As if inside SASSIGN */
7e363e51 1436 }
1c846c1f 1437
5dc0d613 1438 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1439
11343788 1440 switch (o->op_type) {
79072805
LW
1441 case OP_FLOP:
1442 case OP_REPEAT:
11343788 1443 list(cBINOPo->op_first);
79072805
LW
1444 break;
1445 case OP_OR:
1446 case OP_AND:
1447 case OP_COND_EXPR:
11343788 1448 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1449 list(kid);
1450 break;
1451 default:
1452 case OP_MATCH:
8782bef2 1453 case OP_QR:
79072805
LW
1454 case OP_SUBST:
1455 case OP_NULL:
11343788 1456 if (!(o->op_flags & OPf_KIDS))
79072805 1457 break;
11343788
MB
1458 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1459 list(cBINOPo->op_first);
1460 return gen_constant_list(o);
79072805
LW
1461 }
1462 case OP_LIST:
11343788 1463 listkids(o);
79072805
LW
1464 break;
1465 case OP_LEAVE:
1466 case OP_LEAVETRY:
5dc0d613 1467 kid = cLISTOPo->op_first;
54310121 1468 list(kid);
25b991bf
VP
1469 kid = kid->op_sibling;
1470 do_kids:
1471 while (kid) {
1472 OP *sib = kid->op_sibling;
c08f093b
VP
1473 if (sib && kid->op_type != OP_LEAVEWHEN)
1474 scalarvoid(kid);
1475 else
54310121 1476 list(kid);
25b991bf 1477 kid = sib;
54310121 1478 }
11206fdd 1479 PL_curcop = &PL_compiling;
54310121 1480 break;
748a9306 1481 case OP_SCOPE:
79072805 1482 case OP_LINESEQ:
25b991bf
VP
1483 kid = cLISTOPo->op_first;
1484 goto do_kids;
79072805 1485 }
11343788 1486 return o;
79072805
LW
1487}
1488
1f676739 1489static OP *
2dd5337b 1490S_scalarseq(pTHX_ OP *o)
79072805 1491{
97aff369 1492 dVAR;
11343788 1493 if (o) {
1496a290
AL
1494 const OPCODE type = o->op_type;
1495
1496 if (type == OP_LINESEQ || type == OP_SCOPE ||
1497 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1498 {
6867be6d 1499 OP *kid;
11343788 1500 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1501 if (kid->op_sibling) {
463ee0b2 1502 scalarvoid(kid);
ed6116ce 1503 }
463ee0b2 1504 }
3280af22 1505 PL_curcop = &PL_compiling;
79072805 1506 }
11343788 1507 o->op_flags &= ~OPf_PARENS;
3280af22 1508 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1509 o->op_flags |= OPf_PARENS;
79072805 1510 }
8990e307 1511 else
11343788
MB
1512 o = newOP(OP_STUB, 0);
1513 return o;
79072805
LW
1514}
1515
76e3520e 1516STATIC OP *
cea2e8a9 1517S_modkids(pTHX_ OP *o, I32 type)
79072805 1518{
11343788 1519 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1520 OP *kid;
11343788 1521 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1522 op_lvalue(kid, type);
79072805 1523 }
11343788 1524 return o;
79072805
LW
1525}
1526
3ad73efd 1527/*
d164302a
GG
1528=for apidoc finalize_optree
1529
1530This function finalizes the optree. Should be called directly after
1531the complete optree is built. It does some additional
1532checking which can't be done in the normal ck_xxx functions and makes
1533the tree thread-safe.
1534
1535=cut
1536*/
1537void
1538Perl_finalize_optree(pTHX_ OP* o)
1539{
1540 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1541
1542 ENTER;
1543 SAVEVPTR(PL_curcop);
1544
1545 finalize_op(o);
1546
1547 LEAVE;
1548}
1549
60dde6b2 1550STATIC void
d164302a
GG
1551S_finalize_op(pTHX_ OP* o)
1552{
1553 PERL_ARGS_ASSERT_FINALIZE_OP;
1554
1555#if defined(PERL_MAD) && defined(USE_ITHREADS)
1556 {
1557 /* Make sure mad ops are also thread-safe */
1558 MADPROP *mp = o->op_madprop;
1559 while (mp) {
1560 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1561 OP *prop_op = (OP *) mp->mad_val;
1562 /* We only need "Relocate sv to the pad for thread safety.", but this
1563 easiest way to make sure it traverses everything */
4dc304e0
FC
1564 if (prop_op->op_type == OP_CONST)
1565 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG
1566 finalize_op(prop_op);
1567 }
1568 mp = mp->mad_next;
1569 }
1570 }
1571#endif
1572
1573 switch (o->op_type) {
1574 case OP_NEXTSTATE:
1575 case OP_DBSTATE:
1576 PL_curcop = ((COP*)o); /* for warnings */
1577 break;
1578 case OP_EXEC:
ea31ed66
GG
1579 if ( o->op_sibling
1580 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
d164302a
GG
1581 && ckWARN(WARN_SYNTAX))
1582 {
ea31ed66
GG
1583 if (o->op_sibling->op_sibling) {
1584 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG
1585 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1586 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1587 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG
1588 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1589 "Statement unlikely to be reached");
1590 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1591 "\t(Maybe you meant system() when you said exec()?)\n");
1592 CopLINE_set(PL_curcop, oldline);
1593 }
1594 }
1595 }
1596 break;
1597
1598 case OP_GV:
1599 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1600 GV * const gv = cGVOPo_gv;
1601 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1602 /* XXX could check prototype here instead of just carping */
1603 SV * const sv = sv_newmortal();
1604 gv_efullname3(sv, gv, NULL);
1605 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1606 "%"SVf"() called too early to check prototype",
1607 SVfARG(sv));
1608 }
1609 }
1610 break;
1611
1612 case OP_CONST:
eb796c7f
GG
1613 if (cSVOPo->op_private & OPpCONST_STRICT)
1614 no_bareword_allowed(o);
1615 /* FALLTHROUGH */
d164302a
GG
1616#ifdef USE_ITHREADS
1617 case OP_HINTSEVAL:
1618 case OP_METHOD_NAMED:
1619 /* Relocate sv to the pad for thread safety.
1620 * Despite being a "constant", the SV is written to,
1621 * for reference counts, sv_upgrade() etc. */
1622 if (cSVOPo->op_sv) {
1623 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1624 if (o->op_type != OP_METHOD_NAMED &&
1625 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1626 {
1627 /* If op_sv is already a PADTMP/MY then it is being used by
1628 * some pad, so make a copy. */
1629 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1630 SvREADONLY_on(PAD_SVl(ix));
1631 SvREFCNT_dec(cSVOPo->op_sv);
1632 }
1633 else if (o->op_type != OP_METHOD_NAMED
1634 && cSVOPo->op_sv == &PL_sv_undef) {
1635 /* PL_sv_undef is hack - it's unsafe to store it in the
1636 AV that is the pad, because av_fetch treats values of
1637 PL_sv_undef as a "free" AV entry and will merrily
1638 replace them with a new SV, causing pad_alloc to think
1639 that this pad slot is free. (When, clearly, it is not)
1640 */
1641 SvOK_off(PAD_SVl(ix));
1642 SvPADTMP_on(PAD_SVl(ix));
1643 SvREADONLY_on(PAD_SVl(ix));
1644 }
1645 else {
1646 SvREFCNT_dec(PAD_SVl(ix));
1647 SvPADTMP_on(cSVOPo->op_sv);
1648 PAD_SETSV(ix, cSVOPo->op_sv);
1649 /* XXX I don't know how this isn't readonly already. */
1650 SvREADONLY_on(PAD_SVl(ix));
1651 }
1652 cSVOPo->op_sv = NULL;
1653 o->op_targ = ix;
1654 }
1655#endif
1656 break;
1657
1658 case OP_HELEM: {
1659 UNOP *rop;
1660 SV *lexname;
1661 GV **fields;
1662 SV **svp, *sv;
1663 const char *key = NULL;
1664 STRLEN keylen;
1665
1666 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1667 break;
1668
1669 /* Make the CONST have a shared SV */
1670 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1671 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1672 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1673 key = SvPV_const(sv, keylen);
1674 lexname = newSVpvn_share(key,
1675 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1676 0);
1677 SvREFCNT_dec(sv);
1678 *svp = lexname;
1679 }
1680
1681 if ((o->op_private & (OPpLVAL_INTRO)))
1682 break;
1683
1684 rop = (UNOP*)((BINOP*)o)->op_first;
1685 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1686 break;
1687 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1688 if (!SvPAD_TYPED(lexname))
1689 break;
1690 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1691 if (!fields || !GvHV(*fields))
1692 break;
1693 key = SvPV_const(*svp, keylen);
1694 if (!hv_fetch(GvHV(*fields), key,
1695 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1696 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1697 "in variable %"SVf" of type %"HEKf,
ce16c625 1698 SVfARG(*svp), SVfARG(lexname),
84cf752c 1699 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG
1700 }
1701 break;
1702 }
1703
1704 case OP_HSLICE: {
1705 UNOP *rop;
1706 SV *lexname;
1707 GV **fields;
1708 SV **svp;
1709 const char *key;
1710 STRLEN keylen;
1711 SVOP *first_key_op, *key_op;
1712
1713 if ((o->op_private & (OPpLVAL_INTRO))
1714 /* I bet there's always a pushmark... */
1715 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1716 /* hmmm, no optimization if list contains only one key. */
1717 break;
1718 rop = (UNOP*)((LISTOP*)o)->op_last;
1719 if (rop->op_type != OP_RV2HV)
1720 break;
1721 if (rop->op_first->op_type == OP_PADSV)
1722 /* @$hash{qw(keys here)} */
1723 rop = (UNOP*)rop->op_first;
1724 else {
1725 /* @{$hash}{qw(keys here)} */
1726 if (rop->op_first->op_type == OP_SCOPE
1727 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1728 {
1729 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1730 }
1731 else
1732 break;
1733 }
1734
1735 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1736 if (!SvPAD_TYPED(lexname))
1737 break;
1738 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1739 if (!fields || !GvHV(*fields))
1740 break;
1741 /* Again guessing that the pushmark can be jumped over.... */
1742 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1743 ->op_first->op_sibling;
1744 for (key_op = first_key_op; key_op;
1745 key_op = (SVOP*)key_op->op_sibling) {
1746 if (key_op->op_type != OP_CONST)
1747 continue;
1748 svp = cSVOPx_svp(key_op);
1749 key = SvPV_const(*svp, keylen);
1750 if (!hv_fetch(GvHV(*fields), key,
1751 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1752 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1753 "in variable %"SVf" of type %"HEKf,
ce16c625 1754 SVfARG(*svp), SVfARG(lexname),
84cf752c 1755 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG
1756 }
1757 }
1758 break;
1759 }
1760 case OP_SUBST: {
1761 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1762 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1763 break;
1764 }
1765 default:
1766 break;
1767 }
1768
1769 if (o->op_flags & OPf_KIDS) {
1770 OP *kid;
1771 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1772 finalize_op(kid);
1773 }
1774}
1775
1776/*
3ad73efd
Z
1777=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1778
1779Propagate lvalue ("modifiable") context to an op and its children.
1780I<type> represents the context type, roughly based on the type of op that
1781would do the modifying, although C<local()> is represented by OP_NULL,
1782because it has no op type of its own (it is signalled by a flag on
001c3c51
FC
1783the lvalue op).
1784
1785This function detects things that can't be modified, such as C<$x+1>, and
1786generates errors for them. For example, C<$x+1 = 2> would cause it to be
1787called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1788
1789It also flags things that need to behave specially in an lvalue context,
1790such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z
1791
1792=cut
1793*/
ddeae0f1 1794
79072805 1795OP *
d3d7d28f 1796Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 1797{
27da23d5 1798 dVAR;
79072805 1799 OP *kid;
ddeae0f1
DM
1800 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1801 int localize = -1;
79072805 1802
13765c85 1803 if (!o || (PL_parser && PL_parser->error_count))
11343788 1804 return o;
79072805 1805
b162f9ea 1806 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1807 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1808 {
b162f9ea 1809 return o;
7e363e51 1810 }
1c846c1f 1811
5c906035
GG
1812 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1813
69974ce6
FC
1814 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1815
11343788 1816 switch (o->op_type) {
68dc0745 1817 case OP_UNDEF:
3280af22 1818 PL_modcount++;
5dc0d613 1819 return o;
5f05dabc 1820 case OP_STUB:
58bde88d 1821 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc 1822 break;
1823 goto nomod;
a0d0e21e 1824 case OP_ENTERSUB:
f79aa60b 1825 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB
1826 !(o->op_flags & OPf_STACKED)) {
1827 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC
1828 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1829 poses, so we need it clear. */
e26df76a 1830 o->op_private &= ~1;
22c35a8c 1831 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1832 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1833 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
1834 break;
1835 }
cd06dffe 1836 else { /* lvalue subroutine call */
777d9014
FC
1837 o->op_private |= OPpLVAL_INTRO
1838 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 1839 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1840 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
d0887bf3 1841 /* Potential lvalue context: */
cd06dffe
GS
1842 o->op_private |= OPpENTERSUB_INARGS;
1843 break;
1844 }
1845 else { /* Compile-time error message: */
1846 OP *kid = cUNOPo->op_first;
1847 CV *cv;
cd06dffe 1848
3ea285d1
AL
1849 if (kid->op_type != OP_PUSHMARK) {
1850 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1851 Perl_croak(aTHX_
1852 "panic: unexpected lvalue entersub "
1853 "args: type/targ %ld:%"UVuf,
1854 (long)kid->op_type, (UV)kid->op_targ);
1855 kid = kLISTOP->op_first;
1856 }
cd06dffe
GS
1857 while (kid->op_sibling)
1858 kid = kid->op_sibling;
1859 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS
1860 break; /* Postpone until runtime */
1861 }
b2ffa427 1862
cd06dffe
GS
1863 kid = kUNOP->op_first;
1864 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1865 kid = kUNOP->op_first;
b2ffa427 1866 if (kid->op_type == OP_NULL)
cd06dffe
GS
1867 Perl_croak(aTHX_
1868 "Unexpected constant lvalue entersub "
55140b79 1869 "entry via type/targ %ld:%"UVuf,
3d811634 1870 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 1871 if (kid->op_type != OP_GV) {
cd06dffe
GS
1872 break;
1873 }
b2ffa427 1874
638eceb6 1875 cv = GvCV(kGVOP_gv);
1c846c1f 1876 if (!cv)
da1dff94 1877 break;
cd06dffe
GS
1878 if (CvLVALUE(cv))
1879 break;
1880 }
1881 }
79072805
LW
1882 /* FALL THROUGH */
1883 default:
a0d0e21e 1884 nomod:
f5d552b4 1885 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 1886 /* grep, foreach, subcalls, refgen */
145b2bbb
FC
1887 if (type == OP_GREPSTART || type == OP_ENTERSUB
1888 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 1889 break;
cea2e8a9 1890 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1891 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
1892 ? "do block"
1893 : (o->op_type == OP_ENTERSUB
1894 ? "non-lvalue subroutine call"
53e06cf0 1895 : OP_DESC(o))),
22c35a8c 1896 type ? PL_op_desc[type] : "local"));
11343788 1897 return o;
79072805 1898
a0d0e21e
LW
1899 case OP_PREINC:
1900 case OP_PREDEC:
1901 case OP_POW:
1902 case OP_MULTIPLY:
1903 case OP_DIVIDE:
1904 case OP_MODULO:
1905 case OP_REPEAT:
1906 case OP_ADD:
1907 case OP_SUBTRACT:
1908 case OP_CONCAT:
1909 case OP_LEFT_SHIFT:
1910 case OP_RIGHT_SHIFT:
1911 case OP_BIT_AND:
1912 case OP_BIT_XOR:
1913 case OP_BIT_OR:
1914 case OP_I_MULTIPLY:
1915 case OP_I_DIVIDE:
1916 case OP_I_MODULO:
1917 case OP_I_ADD:
1918 case OP_I_SUBTRACT:
11343788 1919 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1920 goto nomod;
3280af22 1921 PL_modcount++;
a0d0e21e 1922 break;
b2ffa427 1923
79072805 1924 case OP_COND_EXPR:
ddeae0f1 1925 localize = 1;
11343788 1926 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 1927 op_lvalue(kid, type);
79072805
LW
1928 break;
1929
1930 case OP_RV2AV:
1931 case OP_RV2HV:
11343788 1932 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1933 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1934 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW
1935 }
1936 /* FALL THROUGH */
79072805 1937 case OP_RV2GV:
5dc0d613 1938 if (scalar_mod_type(o, type))
3fe9a6f1 1939 goto nomod;
11343788 1940 ref(cUNOPo->op_first, o->op_type);
79072805 1941 /* FALL THROUGH */
79072805
LW
1942 case OP_ASLICE:
1943 case OP_HSLICE:
78f9721b
SM
1944 if (type == OP_LEAVESUBLV)
1945 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1946 localize = 1;
78f9721b
SM
1947 /* FALL THROUGH */
1948 case OP_AASSIGN:
93a17b20
LW
1949 case OP_NEXTSTATE:
1950 case OP_DBSTATE:
e6438c1a 1951 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1952 break;
28c5b5bc
RGS
1953 case OP_AV2ARYLEN:
1954 PL_hints |= HINT_BLOCK_SCOPE;
1955 if (type == OP_LEAVESUBLV)
1956 o->op_private |= OPpMAYBE_LVSUB;
1957 PL_modcount++;
1958 break;
463ee0b2 1959 case OP_RV2SV:
aeea060c 1960 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1961 localize = 1;
463ee0b2 1962 /* FALL THROUGH */
79072805 1963 case OP_GV:
3280af22 1964 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1965 case OP_SASSIGN:
bf4b1e52
GS
1966 case OP_ANDASSIGN:
1967 case OP_ORASSIGN:
c963b151 1968 case OP_DORASSIGN:
ddeae0f1
DM
1969 PL_modcount++;
1970 break;
1971
8990e307 1972 case OP_AELEMFAST:
93bad3fd 1973 case OP_AELEMFAST_LEX:
6a077020 1974 localize = -1;
3280af22 1975 PL_modcount++;
8990e307
LW
1976 break;
1977
748a9306
LW
1978 case OP_PADAV:
1979 case OP_PADHV:
e6438c1a 1980 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
1981 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1982 return o; /* Treat \(@foo) like ordinary list. */
1983 if (scalar_mod_type(o, type))
3fe9a6f1 1984 goto nomod;
78f9721b
SM
1985 if (type == OP_LEAVESUBLV)
1986 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW
1987 /* FALL THROUGH */
1988 case OP_PADSV:
3280af22 1989 PL_modcount++;
ddeae0f1 1990 if (!type) /* local() */
5ede95a0
BF
1991 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1992 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW
1993 break;
1994
748a9306 1995 case OP_PUSHMARK:
ddeae0f1 1996 localize = 0;
748a9306 1997 break;
b2ffa427 1998
69969c6f 1999 case OP_KEYS:
d8065907 2000 case OP_RKEYS:
fad4a2e4 2001 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2002 goto nomod;
5d82c453
GA
2003 goto lvalue_func;
2004 case OP_SUBSTR:
2005 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2006 goto nomod;
5f05dabc 2007 /* FALL THROUGH */
a0d0e21e 2008 case OP_POS:
463ee0b2 2009 case OP_VEC:
fad4a2e4 2010 lvalue_func:
78f9721b
SM
2011 if (type == OP_LEAVESUBLV)
2012 o->op_private |= OPpMAYBE_LVSUB;
11343788
MB
2013 pad_free(o->op_targ);
2014 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 2015 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788 2016 if (o->op_flags & OPf_KIDS)
3ad73efd 2017 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 2018 break;
a0d0e21e 2019
463ee0b2
LW
2020 case OP_AELEM:
2021 case OP_HELEM:
11343788 2022 ref(cBINOPo->op_first, o->op_type);
68dc0745 2023 if (type == OP_ENTERSUB &&
5dc0d613
MB
2024 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2025 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
2026 if (type == OP_LEAVESUBLV)
2027 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2028 localize = 1;
3280af22 2029 PL_modcount++;
463ee0b2
LW
2030 break;
2031
2032 case OP_SCOPE:
2033 case OP_LEAVE:
2034 case OP_ENTER:
78f9721b 2035 case OP_LINESEQ:
ddeae0f1 2036 localize = 0;
11343788 2037 if (o->op_flags & OPf_KIDS)
3ad73efd 2038 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW
2039 break;
2040
2041 case OP_NULL:
ddeae0f1 2042 localize = 0;
638bc118
GS
2043 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2044 goto nomod;
2045 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2046 break;
11343788 2047 if (o->op_targ != OP_LIST) {
3ad73efd 2048 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW
2049 break;
2050 }
2051 /* FALL THROUGH */
463ee0b2 2052 case OP_LIST:
ddeae0f1 2053 localize = 0;
11343788 2054 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG
2055 /* elements might be in void context because the list is
2056 in scalar context or because they are attribute sub calls */
2057 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2058 op_lvalue(kid, type);
463ee0b2 2059 break;
78f9721b
SM
2060
2061 case OP_RETURN:
2062 if (type != OP_LEAVESUBLV)
2063 goto nomod;
3ad73efd 2064 break; /* op_lvalue()ing was handled by ck_return() */
1efec5ed
FC
2065
2066 case OP_COREARGS:
2067 return o;
463ee0b2 2068 }
58d95175 2069
8be1be90
AMS
2070 /* [20011101.069] File test operators interpret OPf_REF to mean that
2071 their argument is a filehandle; thus \stat(".") should not set
2072 it. AMS 20011102 */
2073 if (type == OP_REFGEN &&
ef69c8fc 2074 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS
2075 return o;
2076
2077 if (type != OP_LEAVESUBLV)
2078 o->op_flags |= OPf_MOD;
2079
2080 if (type == OP_AASSIGN || type == OP_SASSIGN)
2081 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM
2082 else if (!type) { /* local() */
2083 switch (localize) {
2084 case 1:
2085 o->op_private |= OPpLVAL_INTRO;
2086 o->op_flags &= ~OPf_SPECIAL;
2087 PL_hints |= HINT_BLOCK_SCOPE;
2088 break;
2089 case 0:
2090 break;
2091 case -1:
a2a5de95
NC
2092 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2093 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2094 }
463ee0b2 2095 }
8be1be90
AMS
2096 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2097 && type != OP_LEAVESUBLV)
2098 o->op_flags |= OPf_REF;
11343788 2099 return o;
463ee0b2
LW
2100}
2101
864dbfa3 2102STATIC bool
5f66b61c 2103S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2104{
2105 switch (type) {
32a60974 2106 case OP_POS:
3fe9a6f1 2107 case OP_SASSIGN:
1efec5ed 2108 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 2109 return FALSE;
2110 /* FALL THROUGH */
2111 case OP_PREINC:
2112 case OP_PREDEC:
2113 case OP_POSTINC:
2114 case OP_POSTDEC:
2115 case OP_I_PREINC:
2116 case OP_I_PREDEC:
2117 case OP_I_POSTINC:
2118 case OP_I_POSTDEC:
2119 case OP_POW:
2120 case OP_MULTIPLY:
2121 case OP_DIVIDE:
2122 case OP_MODULO:
2123 case OP_REPEAT:
2124 case OP_ADD:
2125 case OP_SUBTRACT:
2126 case OP_I_MULTIPLY:
2127 case OP_I_DIVIDE:
2128 case OP_I_MODULO:
2129 case OP_I_ADD:
2130 case OP_I_SUBTRACT:
2131 case OP_LEFT_SHIFT:
2132 case OP_RIGHT_SHIFT:
2133 case OP_BIT_AND:
2134 case OP_BIT_XOR:
2135 case OP_BIT_OR:
2136 case OP_CONCAT:
2137 case OP_SUBST:
2138 case OP_TRANS:
bb16bae8 2139 case OP_TRANSR:
49e9fbe6
GS
2140 case OP_READ:
2141 case OP_SYSREAD:
2142 case OP_RECV:
bf4b1e52
GS
2143 case OP_ANDASSIGN:
2144 case OP_ORASSIGN:
410d09fe 2145 case OP_DORASSIGN:
3fe9a6f1 2146 return TRUE;
2147 default:
2148 return FALSE;
2149 }
2150}
2151
35cd451c 2152STATIC bool
5f66b61c 2153S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2154{
7918f24d
NC
2155 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2156
35cd451c
GS
2157 switch (o->op_type) {
2158 case OP_PIPE_OP:
2159 case OP_SOCKPAIR:
504618e9 2160 if (numargs == 2)
35cd451c
GS
2161 return TRUE;
2162 /* FALL THROUGH */
2163 case OP_SYSOPEN:
2164 case OP_OPEN:
ded8aa31 2165 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
2166 case OP_SOCKET:
2167 case OP_OPEN_DIR:
2168 case OP_ACCEPT:
504618e9 2169 if (numargs == 1)
35cd451c 2170 return TRUE;
5f66b61c 2171 /* FALLTHROUGH */
35cd451c
GS
2172 default:
2173 return FALSE;
2174 }
2175}
2176
0d86688d
NC
2177static OP *
2178S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2179{
11343788 2180 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2181 OP *kid;
11343788 2182 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
2183 ref(kid, type);
2184 }
11343788 2185 return o;
463ee0b2
LW
2186}
2187
2188OP *
e4c5ccf3 2189Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2190{
27da23d5 2191 dVAR;
463ee0b2 2192 OP *kid;
463ee0b2 2193
7918f24d
NC
2194 PERL_ARGS_ASSERT_DOREF;
2195
13765c85 2196 if (!o || (PL_parser && PL_parser->error_count))
11343788 2197 return o;
463ee0b2 2198
11343788 2199 switch (o->op_type) {
a0d0e21e 2200 case OP_ENTERSUB:
f4df43b5 2201 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB
2202 !(o->op_flags & OPf_STACKED)) {
2203 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2204 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2205 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2206 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2207 o->op_flags |= OPf_SPECIAL;
e26df76a 2208 o->op_private &= ~1;
8990e307 2209 }
767eda44 2210 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG
2211 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2212 : type == OP_RV2HV ? OPpDEREF_HV
2213 : OPpDEREF_SV);
767eda44
FC
2214 o->op_flags |= OPf_MOD;
2215 }
2216
8990e307 2217 break;
aeea060c 2218
463ee0b2 2219 case OP_COND_EXPR:
11343788 2220 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2221 doref(kid, type, set_op_ref);
463ee0b2 2222 break;
8990e307 2223 case OP_RV2SV:
35cd451c
GS
2224 if (type == OP_DEFINED)
2225 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2226 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW
2227 /* FALL THROUGH */
2228 case OP_PADSV:
5f05dabc 2229 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
2230 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2231 : type == OP_RV2HV ? OPpDEREF_HV
2232 : OPpDEREF_SV);
11343788 2233 o->op_flags |= OPf_MOD;
a0d0e21e 2234 }
8990e307 2235 break;
1c846c1f 2236
463ee0b2
LW
2237 case OP_RV2AV:
2238 case OP_RV2HV:
e4c5ccf3
RH
2239 if (set_op_ref)
2240 o->op_flags |= OPf_REF;
8990e307 2241 /* FALL THROUGH */
463ee0b2 2242 case OP_RV2GV:
35cd451c
GS
2243 if (type == OP_DEFINED)
2244 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2245 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2246 break;
8990e307 2247
463ee0b2
LW
2248 case OP_PADAV:
2249 case OP_PADHV:
e4c5ccf3
RH
2250 if (set_op_ref)
2251 o->op_flags |= OPf_REF;
79072805 2252 break;
aeea060c 2253
8990e307 2254 case OP_SCALAR:
79072805 2255 case OP_NULL:
11343788 2256 if (!(o->op_flags & OPf_KIDS))
463ee0b2 2257 break;
e4c5ccf3 2258 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW
2259 break;
2260 case OP_AELEM:
2261 case OP_HELEM:
e4c5ccf3 2262 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2263 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
2264 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2265 : type == OP_RV2HV ? OPpDEREF_HV
2266 : OPpDEREF_SV);
11343788 2267 o->op_flags |= OPf_MOD;
8990e307 2268 }
79072805
LW
2269 break;
2270
463ee0b2 2271 case OP_SCOPE:
79072805 2272 case OP_LEAVE:
e4c5ccf3
RH
2273 set_op_ref = FALSE;
2274 /* FALL THROUGH */
79072805 2275 case OP_ENTER:
8990e307 2276 case OP_LIST:
11343788 2277 if (!(o->op_flags & OPf_KIDS))
79072805 2278 break;
e4c5ccf3 2279 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2280 break;
a0d0e21e
LW
2281 default:
2282 break;
79072805 2283 }
11343788 2284 return scalar(o);
8990e307 2285
79072805
LW
2286}
2287
09bef843
SB
2288STATIC OP *
2289S_dup_attrlist(pTHX_ OP *o)
2290{
97aff369 2291 dVAR;
0bd48802 2292 OP *rop;
09bef843 2293
7918f24d
NC
2294 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2295
09bef843
SB
2296 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2297 * where the first kid is OP_PUSHMARK and the remaining ones
2298 * are OP_CONST. We need to push the OP_CONST values.
2299 */
2300 if (o->op_type == OP_CONST)
b37c2d43 2301 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC
2302#ifdef PERL_MAD
2303 else if (o->op_type == OP_NULL)
1d866c12 2304 rop = NULL;
eb8433b7 2305#endif
09bef843
SB
2306 else {
2307 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2308 rop = NULL;
09bef843
SB
2309 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2310 if (o->op_type == OP_CONST)
2fcb4757 2311 rop = op_append_elem(OP_LIST, rop,
09bef843 2312 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2313 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB
2314 }
2315 }
2316 return rop;
2317}
2318
2319STATIC void
95f0a2f1 2320S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 2321{
27da23d5 2322 dVAR;
09bef843
SB
2323 SV *stashsv;
2324
7918f24d
NC
2325 PERL_ARGS_ASSERT_APPLY_ATTRS;
2326
09bef843
SB
2327 /* fake up C<use attributes $pkg,$rv,@attrs> */
2328 ENTER; /* need to protect against side-effects of 'use' */
5aaec2b4 2329 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 2330
09bef843 2331#define ATTRSMODULE "attributes"
95f0a2f1
SB
2332#define ATTRSMODULE_PM "attributes.pm"
2333
2334 if (for_my) {
95f0a2f1 2335 /* Don't force the C<use> if we don't need it. */
a4fc7abc 2336 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 2337 if (svp && *svp != &PL_sv_undef)
6f207bd3 2338 NOOP; /* already in %INC */
95f0a2f1
SB
2339 else
2340 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 2341 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB
2342 }
2343 else {
2344 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL
2345 newSVpvs(ATTRSMODULE),
2346 NULL,
2fcb4757 2347 op_prepend_elem(OP_LIST,
95f0a2f1 2348 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2349 op_prepend_elem(OP_LIST,
95f0a2f1
SB
2350 newSVOP(OP_CONST, 0,
2351 newRV(target)),
2352 dup_attrlist(attrs))));
2353 }
09bef843
SB
2354 LEAVE;
2355}
2356
95f0a2f1
SB
2357STATIC void
2358S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2359{
97aff369 2360 dVAR;
95f0a2f1
SB
2361 OP *pack, *imop, *arg;
2362 SV *meth, *stashsv;
2363
7918f24d
NC
2364 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2365
95f0a2f1
SB
2366 if (!attrs)
2367 return;
2368
2369 assert(target->op_type == OP_PADSV ||
2370 target->op_type == OP_PADHV ||
2371 target->op_type == OP_PADAV);
2372
2373 /* Ensure that attributes.pm is loaded. */
dd2155a4 2374 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB
2375
2376 /* Need package name for method call. */
6136c704 2377 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB
2378
2379 /* Build up the real arg-list. */
5aaec2b4
NC
2380 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2381
95f0a2f1
SB
2382 arg = newOP(OP_PADSV, 0);
2383 arg->op_targ = target->op_targ;
2fcb4757 2384 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2385 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2386 op_prepend_elem(OP_LIST,
95f0a2f1 2387 newUNOP(OP_REFGEN, 0,
3ad73efd 2388 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB
2389 dup_attrlist(attrs)));
2390
2391 /* Fake up a method call to import */
18916d0d 2392 meth = newSVpvs_share("import");
95f0a2f1 2393 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z
2394 op_append_elem(OP_LIST,
2395 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2396 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB
2397
2398 /* Combine the ops. */
2fcb4757 2399 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB
2400}
2401
2402/*
2403=notfor apidoc apply_attrs_string
2404
2405Attempts to apply a list of attributes specified by the C<attrstr> and
2406C<len> arguments to the subroutine identified by the C<cv> argument which
2407is expected to be associated with the package identified by the C<stashpv>
2408argument (see L<attributes>). It gets this wrong, though, in that it
2409does not correctly identify the boundaries of the individual attribute
2410specifications within C<attrstr>. This is not really intended for the
2411public API, but has to be listed here for systems such as AIX which
2412need an explicit export list for symbols. (It's called from XS code
2413in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2414to respect attribute syntax properly would be welcome.
2415
2416=cut
2417*/
2418
be3174d2 2419void
6867be6d
AL
2420Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2421 const char *attrstr, STRLEN len)
be3174d2 2422{
5f66b61c 2423 OP *attrs = NULL;
be3174d2 2424
7918f24d
NC
2425 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2426
be3174d2
GS
2427 if (!len) {
2428 len = strlen(attrstr);
2429 }
2430
2431 while (len) {
2432 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2433 if (len) {
890ce7af 2434 const char * const sstr = attrstr;
be3174d2 2435 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2436 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS
2437 newSVOP(OP_CONST, 0,
2438 newSVpvn(sstr, attrstr-sstr)));
2439 }
2440 }
2441
2442 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2443 newSVpvs(ATTRSMODULE),
2fcb4757 2444 NULL, op_prepend_elem(OP_LIST,
be3174d2 2445 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2446 op_prepend_elem(OP_LIST,
be3174d2 2447 newSVOP(OP_CONST, 0,
ad64d0ec 2448 newRV(MUTABLE_SV(cv))),
be3174d2
GS
2449 attrs)));
2450}
2451
09bef843 2452STATIC OP *
95f0a2f1 2453S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2454{
97aff369 2455 dVAR;
93a17b20 2456 I32 type;
a1fba7eb 2457 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2458
7918f24d
NC
2459 PERL_ARGS_ASSERT_MY_KID;
2460
13765c85 2461 if (!o || (PL_parser && PL_parser->error_count))
11343788 2462 return o;
93a17b20 2463
bc61e325 2464 type = o->op_type;
eb8433b7
NC
2465 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2466 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2467 return o;
2468 }
2469
93a17b20 2470 if (type == OP_LIST) {
6867be6d 2471 OP *kid;
11343788 2472 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2473 my_kid(kid, attrs, imopsp);
0865059d 2474 return o;
eb8433b7
NC
2475 } else if (type == OP_UNDEF
2476#ifdef PERL_MAD
2477 || type == OP_STUB
2478#endif
2479 ) {
7766148a 2480 return o;
77ca0c92
LW
2481 } else if (type == OP_RV2SV || /* "our" declaration */
2482 type == OP_RV2AV ||
2483 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2484 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2485 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2486 OP_DESC(o),
12bd6ede
DM
2487 PL_parser->in_my == KEY_our
2488 ? "our"
2489 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2490 } else if (attrs) {
551405c4 2491 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM
2492 PL_parser->in_my = FALSE;
2493 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS
2494 apply_attrs(GvSTASH(gv),
2495 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC
2496 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2497 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
1ce0b88c
RGS
2498 attrs, FALSE);
2499 }
192587c2 2500 o->op_private |= OPpOUR_INTRO;
77ca0c92 2501 return o;
95f0a2f1
SB
2502 }
2503 else if (type != OP_PADSV &&
93a17b20
LW
2504 type != OP_PADAV &&
2505 type != OP_PADHV &&
2506 type != OP_PUSHMARK)
2507 {
eb64745e 2508 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2509 OP_DESC(o),
12bd6ede
DM
2510 PL_parser->in_my == KEY_our
2511 ? "our"
2512 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2513 return o;
93a17b20 2514 }
09bef843
SB
2515 else if (attrs && type != OP_PUSHMARK) {
2516 HV *stash;
09bef843 2517
12bd6ede
DM
2518 PL_parser->in_my = FALSE;
2519 PL_parser->in_my_stash = NULL;
eb64745e 2520
09bef843 2521 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM
2522 stash = PAD_COMPNAME_TYPE(o->op_targ);
2523 if (!stash)
09bef843 2524 stash = PL_curstash;
95f0a2f1 2525 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2526 }
11343788
MB
2527 o->op_flags |= OPf_MOD;
2528 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2529 if (stately)
952306ac 2530 o->op_private |= OPpPAD_STATE;
11343788 2531 return o;
93a17b20
LW
2532}
2533
2534OP *
09bef843
SB
2535Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2536{
97aff369 2537 dVAR;
0bd48802 2538 OP *rops;
95f0a2f1
SB
2539 int maybe_scalar = 0;
2540
7918f24d
NC
2541 PERL_ARGS_ASSERT_MY_ATTRS;
2542
d2be0de5 2543/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2544 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2545#if 0
09bef843
SB
2546 if (o->op_flags & OPf_PARENS)
2547 list(o);
95f0a2f1
SB
2548 else
2549 maybe_scalar = 1;
d2be0de5
YST
2550#else
2551 maybe_scalar = 1;
2552#endif
09bef843
SB
2553 if (attrs)
2554 SAVEFREEOP(attrs);
5f66b61c 2555 rops = NULL;
95f0a2f1
SB
2556 o = my_kid(o, attrs, &rops);
2557 if (rops) {
2558 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2559 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB
2560 o->op_private |= OPpLVAL_INTRO;
2561 }
f5d1ed10
FC
2562 else {
2563 /* The listop in rops might have a pushmark at the beginning,
2564 which will mess up list assignment. */
2565 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2566 if (rops->op_type == OP_LIST &&
2567 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2568 {
2569 OP * const pushmark = lrops->op_first;
2570 lrops->op_first = pushmark->op_sibling;
2571 op_free(pushmark);
2572 }
2fcb4757 2573 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2574 }
95f0a2f1 2575 }
12bd6ede
DM
2576 PL_parser->in_my = FALSE;
2577 PL_parser->in_my_stash = NULL;
eb64745e 2578 return o;
09bef843
SB
2579}
2580
2581OP *
864dbfa3 2582Perl_sawparens(pTHX_ OP *o)
79072805 2583{
96a5add6 2584 PERL_UNUSED_CONTEXT;
79072805
LW
2585 if (o)
2586 o->op_flags |= OPf_PARENS;
2587 return o;
2588}
2589
2590OP *
864dbfa3 2591Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2592{
11343788 2593 OP *o;
59f00321 2594 bool ismatchop = 0;
1496a290
AL
2595 const OPCODE ltype = left->op_type;
2596 const OPCODE rtype = right->op_type;
79072805 2597
7918f24d
NC
2598 PERL_ARGS_ASSERT_BIND_MATCH;
2599
1496a290
AL
2600 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2601 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2602 {
1496a290 2603 const char * const desc
bb16bae8
FC
2604 = PL_op_desc[(
2605 rtype == OP_SUBST || rtype == OP_TRANS
2606 || rtype == OP_TRANSR
2607 )
666ea192 2608 ? (int)rtype : OP_MATCH];
c6771ab6
FC
2609 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2610 GV *gv;
2611 SV * const name =
2612 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2613 ? cUNOPx(left)->op_first->op_type == OP_GV
2614 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2615 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2616 : NULL
ba510004
FC
2617 : varname(
2618 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2619 );
c6771ab6
FC
2620 if (name)
2621 Perl_warner(aTHX_ packWARN(WARN_MISC),
2622 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2623 desc, name, name);
2624 else {
2625 const char * const sample = (isary
666ea192 2626 ? "@array" : "%hash");
c6771ab6 2627 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2628 "Applying %s to %s will act on scalar(%s)",
599cee73 2629 desc, sample, sample);
c6771ab6 2630 }
2ae324a7 2631 }
2632
1496a290 2633 if (rtype == OP_CONST &&
5cc9e5c9
RH
2634 cSVOPx(right)->op_private & OPpCONST_BARE &&
2635 cSVOPx(right)->op_private & OPpCONST_STRICT)
2636 {
2637 no_bareword_allowed(right);
2638 }
2639
bb16bae8 2640 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC
2641 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2642 type == OP_NOT)
2643 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC
2644 if (rtype == OP_TRANSR && type == OP_NOT)
2645 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2646
2474a784
FC
2647 ismatchop = (rtype == OP_MATCH ||
2648 rtype == OP_SUBST ||
bb16bae8 2649 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2650 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS
2651 if (ismatchop && right->op_private & OPpTARGET_MY) {
2652 right->op_targ = 0;
2653 right->op_private &= ~OPpTARGET_MY;
2654 }
2655 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL
2656 OP *newleft;
2657
79072805 2658 right->op_flags |= OPf_STACKED;
bb16bae8 2659 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2660 ! (rtype == OP_TRANS &&
4f4d7508
DC
2661 right->op_private & OPpTRANS_IDENTICAL) &&
2662 ! (rtype == OP_SUBST &&
2663 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2664 newleft = op_lvalue(left, rtype);
1496a290
AL
2665 else
2666 newleft = left;
bb16bae8 2667 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2668 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2669 else
2fcb4757 2670 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2671 if (type == OP_NOT)
11343788
MB
2672 return newUNOP(OP_NOT, 0, scalar(o));
2673 return o;
79072805
LW
2674 }
2675 else
2676 return bind_match(type, left,
d63c20f2 2677 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW
2678}
2679
2680OP *
864dbfa3 2681Perl_invert(pTHX_ OP *o)
79072805 2682{
11343788 2683 if (!o)
1d866c12 2684 return NULL;
11343788 2685 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
2686}
2687
3ad73efd
Z
2688/*
2689=for apidoc Amx|OP *|op_scope|OP *o
2690
2691Wraps up an op tree with some additional ops so that at runtime a dynamic
2692scope will be created. The original ops run in the new dynamic scope,
2693and then, provided that they exit normally, the scope will be unwound.
2694The additional ops used to create and unwind the dynamic scope will
2695normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2696instead if the ops are simple enough to not need the full dynamic scope
2697structure.
2698
2699=cut
2700*/
2701
79072805 2702OP *
3ad73efd 2703Perl_op_scope(pTHX_ OP *o)
79072805 2704{
27da23d5 2705 dVAR;
79072805 2706 if (o) {
3280af22 2707 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2fcb4757 2708 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2709 o->op_type = OP_LEAVE;
22c35a8c 2710 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2711 }
fdb22418
HS
2712 else if (o->op_type == OP_LINESEQ) {
2713 OP *kid;
2714 o->op_type = OP_SCOPE;
2715 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2716 kid = ((LISTOP*)o)->op_first;
59110972 2717 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2718 op_null(kid);
59110972
RH
2719
2720 /* The following deals with things like 'do {1 for 1}' */
2721 kid = kid->op_sibling;
2722 if (kid &&
2723 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2724 op_null(kid);
2725 }
463ee0b2 2726 }
fdb22418 2727 else
5f66b61c 2728 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW
2729 }
2730 return o;
2731}
1930840b 2732
a0d0e21e 2733int
864dbfa3 2734Perl_block_start(pTHX_ int full)
79072805 2735{
97aff369 2736 dVAR;
73d840c0 2737 const int retval = PL_savestack_ix;
1930840b 2738
dd2155a4 2739 pad_block_start(full);
b3ac6de7 2740 SAVEHINTS();
3280af22 2741 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2742 SAVECOMPILEWARNINGS();
72dc9ed5 2743 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2744
a88d97bf 2745 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2746
a0d0e21e
LW
2747 return retval;
2748}
2749
2750OP*
864dbfa3 2751Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2752{
97aff369 2753 dVAR;
6867be6d 2754 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b
BM
2755 OP* retval = scalarseq(seq);
2756
a88d97bf 2757 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2758
e9818f4e 2759 LEAVE_SCOPE(floor);
623e6609 2760 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2761 if (needblockscope)
3280af22 2762 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2763 pad_leavemy();
1930840b 2764
a88d97bf 2765 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2766
a0d0e21e
LW
2767 return retval;
2768}
2769
fd85fad2
BM
2770/*
2771=head1 Compile-time scope hooks
2772
3e4ddde5 2773=for apidoc Aox||blockhook_register
fd85fad2
BM
2774
2775Register a set of hooks to be called when the Perl lexical scope changes
2776at compile time. See L<perlguts/"Compile-time scope hooks">.
2777
2778=cut
2779*/
2780
bb6c22e7
BM
2781void
2782Perl_blockhook_register(pTHX_ BHK *hk)
2783{
2784 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2785
2786 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2787}
2788
76e3520e 2789STATIC OP *
cea2e8a9 2790S_newDEFSVOP(pTHX)
54b9620d 2791{
97aff369 2792 dVAR;
cc76b5cc 2793 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 2794 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS
2795 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2796 }
2797 else {
551405c4 2798 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS
2799 o->op_targ = offset;
2800 return o;
2801 }
54b9620d
MB
2802}
2803
a0d0e21e 2804void
864dbfa3 2805Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2806{
97aff369 2807 dVAR;
7918f24d
NC
2808
2809 PERL_ARGS_ASSERT_NEWPROG;
2810
3280af22 2811 if (PL_in_eval) {
86a64801 2812 PERL_CONTEXT *cx;
63429d50 2813 I32 i;
b295d113
TH
2814 if (PL_eval_root)
2815 return;
faef0170
HS
2816 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2817 ((PL_in_eval & EVAL_KEEPERR)
2818 ? OPf_SPECIAL : 0), o);
86a64801
GG
2819
2820 cx = &cxstack[cxstack_ix];
2821 assert(CxTYPE(cx) == CXt_EVAL);
2822
2823 if ((cx->blk_gimme & G_WANT) == G_VOID)
2824 scalarvoid(PL_eval_root);
2825 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2826 list(PL_eval_root);
2827 else
2828 scalar(PL_eval_root);
2829
5983a79d
BM
2830 /* don't use LINKLIST, since PL_eval_root might indirect through
2831 * a rather expensive function call and LINKLIST evaluates its
2832 * argument more than once */
2833 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS
2834 PL_eval_root->op_private |= OPpREFCOUNTED;
2835 OpREFCNT_set(PL_eval_root, 1);
3280af22 2836 PL_eval_root->op_next = 0;
63429d50
FC
2837 i = PL_savestack_ix;
2838 SAVEFREEOP(o);
2839 ENTER;
a2efc822 2840 CALL_PEEP(PL_eval_start);
86a64801 2841 finalize_optree(PL_eval_root);
63429d50
FC
2842 LEAVE;
2843 PL_savestack_ix = i;
a0d0e21e
LW
2844 }
2845 else {
6be89cf9
AE
2846 if (o->op_type == OP_STUB) {
2847 PL_comppad_name = 0;
2848 PL_compcv = 0;
d2c837a0 2849 S_op_destroy(aTHX_ o);
a0d0e21e 2850 return;
6be89cf9 2851 }
3ad73efd 2852 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS
2853 PL_curcop = &PL_compiling;
2854 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
2855 PL_main_root->op_private |= OPpREFCOUNTED;
2856 OpREFCNT_set(PL_main_root, 1);
3280af22 2857 PL_main_root->op_next = 0;
a2efc822 2858 CALL_PEEP(PL_main_start);
d164302a 2859 finalize_optree(PL_main_root);
3280af22 2860 PL_compcv = 0;
3841441e 2861
4fdae800 2862 /* Register with debugger */
84902520 2863 if (PERLDB_INTER) {
b96d8cd9 2864 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS
2865 if (cv) {
2866 dSP;
924508f0 2867 PUSHMARK(SP);
ad64d0ec 2868 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 2869 PUTBACK;
ad64d0ec 2870 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS
2871 }
2872 }
79072805 2873 }
79072805
LW
2874}
2875
2876OP *
864dbfa3 2877Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2878{
97aff369 2879 dVAR;
7918f24d
NC
2880
2881 PERL_ARGS_ASSERT_LOCALIZE;
2882
79072805 2883 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
2884/* [perl #17376]: this appears to be premature, and results in code such as
2885 C< our(%x); > executing in list mode rather than void mode */
2886#if 0
79072805 2887 list(o);
d2be0de5 2888#else
6f207bd3 2889 NOOP;
d2be0de5 2890#endif
8990e307 2891 else {
f06b5848
DM
2892 if ( PL_parser->bufptr > PL_parser->oldbufptr
2893 && PL_parser->bufptr[-1] == ','
041457d9 2894 && ckWARN(WARN_PARENTHESIS))
64420d0d 2895 {
f06b5848 2896 char *s = PL_parser->bufptr;
bac662ee 2897 bool sigil = FALSE;
64420d0d 2898
8473848f 2899 /* some heuristics to detect a potential error */
bac662ee 2900 while (*s && (strchr(", \t\n", *s)))
64420d0d 2901 s++;
8473848f 2902
bac662ee
TS
2903 while (1) {
2904 if (*s && strchr("@$%*", *s) && *++s
2905 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2906 s++;
2907 sigil = TRUE;
2908 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2909 s++;
2910 while (*s && (strchr(", \t\n", *s)))
2911 s++;
2912 }
2913 else
2914 break;
2915 }
2916 if (sigil && (*s == ';' || *s == '=')) {
2917 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2918 "Parentheses missing around \"%s\" list",
12bd6ede
DM
2919 lex
2920 ? (PL_parser->in_my == KEY_our
2921 ? "our"
2922 : PL_parser->in_my == KEY_state
2923 ? "state"
2924 : "my")
2925 : "local");
8473848f 2926 }
8990e307
LW
2927 }
2928 }
93a17b20 2929 if (lex)
eb64745e 2930 o = my(o);
93a17b20 2931 else
3ad73efd 2932 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM
2933 PL_parser->in_my = FALSE;
2934 PL_parser->in_my_stash = NULL;
eb64745e 2935 return o;
79072805
LW
2936}
2937
2938OP *
864dbfa3 2939Perl_jmaybe(pTHX_ OP *o)
79072805 2940{
7918f24d
NC
2941 PERL_ARGS_ASSERT_JMAYBE;
2942
79072805 2943 if (o->op_type == OP_LIST) {
fafc274c 2944 OP * const o2
d4c19fe8 2945 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 2946 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW
2947 }
2948 return o;
2949}
2950
985b9e54
GG
2951PERL_STATIC_INLINE OP *
2952S_op_std_init(pTHX_ OP *o)
2953{
2954 I32 type = o->op_type;
2955
2956 PERL_ARGS_ASSERT_OP_STD_INIT;
2957
2958 if (PL_opargs[type] & OA_RETSCALAR)
2959 scalar(o);
2960 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2961 o->op_targ = pad_alloc(type, SVs_PADTMP);
2962
2963 return o;
2964}
2965
2966PERL_STATIC_INLINE OP *
2967S_op_integerize(pTHX_ OP *o)
2968{
2969 I32 type = o->op_type;
2970
2971 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2972
2973 /* integerize op, unless it happens to be C<-foo>.
2974 * XXX should pp_i_negate() do magic string negation instead? */
2975 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2976 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2977 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2978 {
f5f19483 2979 dVAR;
985b9e54
GG
2980 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2981 }
2982
2983 if (type == OP_NEGATE)
2984 /* XXX might want a ck_negate() for this */
2985 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2986
2987 return o;
2988}
2989
1f676739 2990static OP *
b7783a12 2991S_fold_constants(pTHX_ register OP *o)
79072805 2992{
27da23d5 2993 dVAR;
001d637e 2994 register OP * VOL curop;
eb8433b7 2995 OP *newop;
8ea43dc8 2996 VOL I32 type = o->op_type;
e3cbe32f 2997 SV * VOL sv = NULL;
b7f7fd0b
NC
2998 int ret = 0;
2999 I32 oldscope;
3000 OP *old_next;
5f2d9966
DM
3001 SV * const oldwarnhook = PL_warnhook;
3002 SV * const olddiehook = PL_diehook;
c427f4d2 3003 COP not_compiling;
b7f7fd0b 3004 dJMPENV;
79072805 3005
7918f24d
NC
3006 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3007
22c35a8c 3008 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
3009 goto nope;
3010
de939608 3011 switch (type) {
de939608
CS
3012 case OP_UCFIRST:
3013 case OP_LCFIRST:
3014 case OP_UC:
3015 case OP_LC:
69dcf70c
MB
3016 case OP_SLT:
3017 case OP_SGT:
3018 case OP_SLE:
3019 case OP_SGE:
3020 case OP_SCMP:
b3fd6149 3021 case OP_SPRINTF:
2de3dbcc 3022 /* XXX what about the numeric ops? */
82ad65bb 3023 if (IN_LOCALE_COMPILETIME)
de939608 3024 goto nope;
553e7bb0 3025 break;
baed7faa
FC
3026 case OP_REPEAT:
3027 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
de939608
CS
3028 }
3029
13765c85 3030 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
3031 goto nope; /* Don't try to run w/ errors */
3032
79072805 3033 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL
3034 const OPCODE type = curop->op_type;
3035 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3036 type != OP_LIST &&
3037 type != OP_SCALAR &&
3038 type != OP_NULL &&
3039 type != OP_PUSHMARK)
7a52d87a 3040 {
79072805
LW
3041 goto nope;
3042 }
3043 }
3044
3045 curop = LINKLIST(o);
b7f7fd0b 3046 old_next = o->op_next;
79072805 3047 o->op_next = 0;
533c011a 3048 PL_op = curop;
b7f7fd0b
NC
3049
3050 oldscope = PL_scopestack_ix;
edb2152a 3051 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3052
c427f4d2
NC
3053 /* Verify that we don't need to save it: */
3054 assert(PL_curcop == &PL_compiling);
3055 StructCopy(&PL_compiling, &not_compiling, COP);
3056 PL_curcop = &not_compiling;
3057 /* The above ensures that we run with all the correct hints of the
3058 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3059 assert(IN_PERL_RUNTIME);
5f2d9966
DM
3060 PL_warnhook = PERL_WARNHOOK_FATAL;
3061 PL_diehook = NULL;
b7f7fd0b
NC
3062 JMPENV_PUSH(ret);
3063
3064 switch (ret) {
3065 case 0:
3066 CALLRUNOPS(aTHX);
3067 sv = *(PL_stack_sp--);
523a0f0c
NC
3068 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3069#ifdef PERL_MAD
3070 /* Can't simply swipe the SV from the pad, because that relies on
3071 the op being freed "real soon now". Under MAD, this doesn't
3072 happen (see the #ifdef below). */
3073 sv = newSVsv(sv);
3074#else
b7f7fd0b 3075 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC
3076#endif
3077 }
b7f7fd0b
NC
3078 else if (SvTEMP(sv)) { /* grab mortal temp? */
3079 SvREFCNT_inc_simple_void(sv);
3080 SvTEMP_off(sv);
3081 }
3082 break;
3083 case 3:
3084 /* Something tried to die. Abandon constant folding. */
3085 /* Pretend the error never happened. */
ab69dbc2 3086 CLEAR_ERRSV();
b7f7fd0b
NC
3087 o->op_next = old_next;
3088 break;
3089 default:
3090 JMPENV_POP;
5f2d9966
DM
3091 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3092 PL_warnhook = oldwarnhook;
3093 PL_diehook = olddiehook;
3094 /* XXX note that this croak may fail as we've already blown away
3095 * the stack - eg any nested evals */
b7f7fd0b
NC
3096 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3097 }
b7f7fd0b 3098 JMPENV_POP;
5f2d9966
DM
3099 PL_warnhook = oldwarnhook;
3100 PL_diehook = olddiehook;
c427f4d2 3101 PL_curcop = &PL_compiling;
edb2152a
NC
3102
3103 if (PL_scopestack_ix > oldscope)
3104 delete_eval_scope();
eb8433b7 3105
b7f7fd0b
NC
3106 if (ret)
3107 goto nope;
3108
eb8433b7 3109#ifndef PERL_MAD
79072805 3110 op_free(o);
eb8433b7 3111#endif
de5e01c2 3112 assert(sv);
79072805 3113 if (type == OP_RV2GV)
159b6efe 3114 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3115 else
ad64d0ec 3116 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
eb8433b7
NC
3117 op_getmad(o,newop,'f');
3118 return newop;
aeea060c 3119
b7f7fd0b 3120 nope:
79072805
LW
3121 return o;
3122}
3123
1f676739 3124static OP *
b7783a12 3125S_gen_constant_list(pTHX_ register OP *o)
79072805 3126{
27da23d5 3127 dVAR;
79072805 3128 register OP *curop;
6867be6d 3129 const I32 oldtmps_floor = PL_tmps_floor;
79072805 3130
a0d0e21e 3131 list(o);
13765c85 3132 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
3133 return o; /* Don't attempt to run with errors */
3134
533c011a 3135 PL_op = curop = LINKLIST(o);
a0d0e21e 3136 o->op_next = 0;
a2efc822 3137 CALL_PEEP(curop);
897d3989 3138 Perl_pp_pushmark(aTHX);
cea2e8a9 3139 CALLRUNOPS(aTHX);
533c011a 3140 PL_op = curop;
78c72037
NC
3141 assert (!(curop->op_flags & OPf_SPECIAL));
3142 assert(curop->op_type == OP_RANGE);
897d3989 3143 Perl_pp_anonlist(aTHX);
3280af22 3144 PL_tmps_floor = oldtmps_floor;
79072805
LW
3145
3146 o->op_type = OP_RV2AV;
22c35a8c 3147 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG
3148 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3149 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3150 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3151 curop = ((UNOP*)o)->op_first;
b37c2d43 3152 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC
3153#ifdef PERL_MAD
3154 op_getmad(curop,o,'O');
3155#else
79072805 3156 op_free(curop);
eb8433b7 3157#endif
5983a79d 3158 LINKLIST(o);
79072805
LW
3159 return list(o);
3160}
3161
3162OP *
864dbfa3 3163Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3164{
27da23d5 3165 dVAR;
d67594ff 3166 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3167 if (!o || o->op_type != OP_LIST)
5f66b61c 3168 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3169 else
5dc0d613 3170 o->op_flags &= ~OPf_WANT;
79072805 3171
22c35a8c 3172 if (!(PL_opargs[type] & OA_MARK))
93c66552 3173 op_null(cLISTOPo->op_first);
bf0571fd
FC
3174 else {
3175 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3176 if (kid2 && kid2->op_type == OP_COREARGS) {
3177 op_null(cLISTOPo->op_first);
3178 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3179 }
3180 }
8990e307 3181
eb160463 3182 o->op_type = (OPCODE)type;
22c35a8c 3183 o->op_ppaddr = PL_ppaddr[type];
11343788 3184 o->op_flags |= flags;
79072805 3185
11343788 3186 o = CHECKOP(type, o);
fe2774ed 3187 if (o->op_type != (unsigned)type)
11343788 3188 return o;
79072805 3189
985b9e54 3190 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW
3191}
3192
2fcb4757
Z
3193/*
3194=head1 Optree Manipulation Functions
3195*/
3196
79072805
LW
3197/* List constructors */
3198
2fcb4757
Z
3199/*
3200=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3201
3202Append an item to the list of ops contained directly within a list-type
3203op, returning the lengthened list. I<first> is the list-type op,
3204and I<last> is the op to append to the list. I<optype> specifies the
3205intended opcode for the list. If I<first> is not already a list of the
3206right type, it will be upgraded into one. If either I<first> or I<last>
3207is null, the other is returned unchanged.
3208
3209=cut
3210*/
3211
79072805 3212OP *
2fcb4757 3213Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3214{
3215 if (!first)
3216 return last;
8990e307
LW
3217
3218 if (!last)
79072805 3219 return first;
8990e307 3220
fe2774ed 3221 if (first->op_type != (unsigned)type
155aba94
GS
3222 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3223 {
3224 return newLISTOP(type, 0, first, last);
3225 }
79072805 3226
a0d0e21e
LW
3227 if (first->op_flags & OPf_KIDS)
3228 ((LISTOP*)first)->op_last->op_sibling = last;
3229 else {
3230 first->op_flags |= OPf_KIDS;
3231 ((LISTOP*)first)->op_first = last;
3232 }
3233 ((LISTOP*)first)->op_last = last;
a0d0e21e 3234 return first;
79072805
LW
3235}
3236
2fcb4757
Z
3237/*
3238=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3239
3240Concatenate the lists of ops contained directly within two list-type ops,
3241returning the combined list. I<first> and I<last> are the list-type ops
3242to concatenate. I<optype> specifies the intended opcode for the list.
3243If either I<first> or I<last> is not already a list of the right type,
3244it will be upgraded into one. If either I<first> or I<last> is null,
3245the other is returned unchanged.
3246
3247=cut
3248*/
3249
79072805 3250OP *
2fcb4757 3251Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3252{
3253 if (!first)
2fcb4757 3254 return last;
8990e307
LW
3255
3256 if (!last)
2fcb4757 3257 return first;
8990e307 3258
fe2774ed 3259 if (first->op_type != (unsigned)type)
2fcb4757 3260 return op_prepend_elem(type, first, last);
8990e307 3261
fe2774ed 3262 if (last->op_type != (unsigned)type)
2fcb4757 3263 return op_append_elem(type, first, last);
79072805 3264
2fcb4757
Z
3265 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3266 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3267 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3268
eb8433b7 3269#ifdef PERL_MAD
2fcb4757
Z
3270 if (((LISTOP*)last)->op_first && first->op_madprop) {
3271 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC
3272 if (mp) {
3273 while (mp->mad_next)
3274 mp = mp->mad_next;
3275 mp->mad_next = first->op_madprop;
3276 }
3277 else {
2fcb4757 3278 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC
3279 }
3280 }
3281 first->op_madprop = last->op_madprop;
3282 last->op_madprop = 0;
3283#endif
3284
2fcb4757 3285 S_op_destroy(aTHX_ last);
238a4c30 3286
2fcb4757 3287 return first;
79072805
LW
3288}
3289
2fcb4757
Z
3290/*
3291=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3292
3293Prepend an item to the list of ops contained directly within a list-type
3294op, returning the lengthened list. I<first> is the op to prepend to the
3295list, and I<last> is the list-type op. I<optype> specifies the intended
3296opcode for the list. If I<last> is not already a list of the right type,
3297it will be upgraded into one. If either I<first> or I<last> is null,
3298the other is returned unchanged.
3299
3300=cut
3301*/
3302
79072805 3303OP *
2fcb4757 3304Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3305{
3306 if (!first)
3307 return last;
8990e307
LW
3308
3309 if (!last)
79072805 3310 return first;
8990e307 3311
fe2774ed 3312 if (last->op_type == (unsigned)type) {
8990e307
LW
3313 if (type == OP_LIST) { /* already a PUSHMARK there */
3314 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3315 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
3316 if (!(first->op_flags & OPf_PARENS))
3317 last->op_flags &= ~OPf_PARENS;
8990e307
LW
3318 }
3319 else {
3320 if (!(last->op_flags & OPf_KIDS)) {
3321 ((LISTOP*)last)->op_last = first;
3322 last->op_flags |= OPf_KIDS;
3323 }
3324 first->op_sibling = ((LISTOP*)last)->op_first;
3325 ((LISTOP*)last)->op_first = first;
79072805 3326 }
117dada2 3327 last->op_flags |= OPf_KIDS;
79072805
LW
3328 return last;
3329 }
3330
3331 return newLISTOP(type, 0, first, last);
3332}
3333
3334/* Constructors */
3335
eb8433b7
NC
3336#ifdef PERL_MAD
3337
3338TOKEN *
3339Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3340{
3341 TOKEN *tk;
99129197 3342 Newxz(tk, 1, TOKEN);
eb8433b7
NC
3343 tk->tk_type = (OPCODE)optype;
3344 tk->tk_type = 12345;
3345 tk->tk_lval = lval;
3346 tk->tk_mad = madprop;
3347 return tk;
3348}
3349
3350void
3351Perl_token_free(pTHX_ TOKEN* tk)
3352{
7918f24d
NC
3353 PERL_ARGS_ASSERT_TOKEN_FREE;
3354
eb8433b7
NC
3355 if (tk->tk_type != 12345)
3356 return;
3357 mad_free(tk->tk_mad);
3358 Safefree(tk);
3359}
3360
3361void
3362Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3363{
3364 MADPROP* mp;
3365 MADPROP* tm;
7918f24d
NC
3366
3367 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3368
eb8433b7
NC
3369 if (tk->tk_type != 12345) {
3370 Perl_warner(aTHX_ packWARN(WARN_MISC),
3371 "Invalid TOKEN object ignored");
3372 return;
3373 }
3374 tm = tk->tk_mad;
3375 if (!tm)
3376 return;
3377
3378 /* faked up qw list? */
3379 if (slot == '(' &&
3380 tm->mad_type == MAD_SV &&
d503a9ba 3381 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC
3382 slot = 'x';
3383
3384 if (o) {
3385 mp = o->op_madprop;
3386 if (mp) {
3387 for (;;) {
3388 /* pretend constant fold didn't happen? */
3389 if (mp->mad_key == 'f' &&
3390 (o->op_type == OP_CONST ||
3391 o->op_type == OP_GV) )
3392 {
3393 token_getmad(tk,(OP*)mp->mad_val,slot);
3394 return;
3395 }
3396 if (!mp->mad_next)
3397 break;
3398 mp = mp->mad_next;
3399 }
3400 mp->mad_next = tm;
3401 mp = mp->mad_next;
3402 }
3403 else {
3404 o->op_madprop = tm;
3405 mp = o->op_madprop;
3406 }
3407 if (mp->mad_key == 'X')
3408 mp->mad_key = slot; /* just change the first one */
3409
3410 tk->tk_mad = 0;
3411 }
3412 else
3413 mad_free(tm);
3414 Safefree(tk);
3415}
3416
3417void
3418Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3419{
3420 MADPROP* mp;
3421 if (!from)
3422 return;
3423 if (o) {
3424 mp = o->op_madprop;
3425 if (mp) {
3426 for (;;) {
3427 /* pretend constant fold didn't happen? */
3428 if (mp->mad_key == 'f' &&
3429 (o->op_type == OP_CONST ||
3430 o->op_type == OP_GV) )
3431 {
3432 op_getmad(from,(OP*)mp->mad_val,slot);
3433 return;
3434 }
3435 if (!mp->mad_next)
3436 break;
3437 mp = mp->mad_next;
3438 }
3439 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3440 }
3441 else {
3442 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3443 }
3444 }
3445}
3446
3447void
3448Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3449{
3450 MADPROP* mp;
3451 if (!from)
3452 return;
3453 if (o) {
3454 mp = o->op_madprop;
3455 if (mp) {
3456 for (;;) {
3457 /* pretend constant fold didn't happen? */
3458 if (mp->mad_key == 'f' &&
3459 (o->op_type == OP_CONST ||
3460 o->op_type == OP_GV) )
3461 {
3462 op_getmad(from,(OP*)mp->mad_val,slot);
3463 return;
3464 }
3465 if (!mp->mad_next)
3466 break;
3467 mp = mp->mad_next;
3468 }
3469 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3470 }
3471 else {
3472 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3473 }
3474 }
3475 else {
99129197
NC
3476 PerlIO_printf(PerlIO_stderr(),
3477 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC
3478 op_free(from);
3479 }
3480}
3481
3482void
3483Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3484{
3485 MADPROP* tm;
3486 if (!mp || !o)
3487 return;
3488 if (slot)
3489 mp->mad_key = slot;
3490 tm = o->op_madprop;
3491 o->op_madprop = mp;
3492 for (;;) {
3493 if (!mp->mad_next)
3494 break;
3495 mp = mp->mad_next;
3496 }
3497 mp->mad_next = tm;
3498}
3499
3500void
3501Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3502{
3503 if (!o)
3504 return;
3505 addmad(tm, &(o->op_madprop), slot);
3506}
3507
3508void
3509Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3510{
3511 MADPROP* mp;
3512 if (!tm || !root)
3513 return;
3514 if (slot)
3515 tm->mad_key = slot;
3516 mp = *root;
3517 if (!mp) {
3518 *root = tm;
3519 return;
3520 }
3521 for (;;) {
3522 if (!mp->mad_next)
3523 break;
3524 mp = mp->mad_next;
3525 }
3526 mp->mad_next = tm;
3527}
3528
3529MADPROP *
3530Perl_newMADsv(pTHX_ char key, SV* sv)
3531{
7918f24d
NC
3532 PERL_ARGS_ASSERT_NEWMADSV;
3533
eb8433b7
NC
3534 return newMADPROP(key, MAD_SV, sv, 0);
3535}
3536
3537MADPROP *
d503a9ba 3538Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 3539{
c111d5f1 3540 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC
3541 mp->mad_next = 0;
3542 mp->mad_key = key;
3543 mp->mad_vlen = vlen;
3544 mp->mad_type = type;
3545 mp->mad_val = val;
3546/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3547 return mp;
3548}
3549
3550void
3551Perl_mad_free(pTHX_ MADPROP* mp)
3552{
3553/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3554 if (!mp)
3555 return;
3556 if (mp->mad_next)
3557 mad_free(mp->mad_next);
bc177e6b 3558/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC
3559 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3560 switch (mp->mad_type) {
3561 case MAD_NULL:
3562 break;
3563 case MAD_PV:
3564 Safefree((char*)mp->mad_val);
3565 break;
3566 case MAD_OP:
3567 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3568 op_free((OP*)mp->mad_val);
3569 break;
3570 case MAD_SV:
ad64d0ec 3571 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC
3572 break;
3573 default:
3574 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3575 break;
3576 }
c111d5f1 3577 PerlMemShared_free(mp);
eb8433b7
NC
3578}
3579
3580#endif
3581
d67eb5f4
Z
3582/*
3583=head1 Optree construction
3584
3585=for apidoc Am|OP *|newNULLLIST
3586
3587Constructs, checks, and returns a new C<stub> op, which represents an
3588empty list expression.
3589
3590=cut
3591*/
3592
79072805 3593OP *
864dbfa3 3594Perl_newNULLLIST(pTHX)
79072805 3595{
8990e307
LW
3596 return newOP(OP_STUB, 0);
3597}
3598
1f676739 3599static OP *
b7783a12 3600S_force_list(pTHX_ OP *o)
8990e307 3601{
11343788 3602 if (!o || o->op_type != OP_LIST)
5f66b61c 3603 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3604 op_null(o);
11343788 3605 return o;
79072805
LW
3606}
3607
d67eb5f4
Z
3608/*
3609=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3610
3611Constructs, checks, and returns an op of any list type. I<type> is
3612the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3613C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3614supply up to two ops to be direct children of the list op; they are
3615consumed by this function and become part of the constructed op tree.
3616
3617=cut
3618*/
3619
79072805 3620OP *
864dbfa3 3621Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3622{
27da23d5 3623 dVAR;
79072805
LW
3624 LISTOP *listop;
3625
e69777c1
GG
3626 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3627
b7dc083c 3628 NewOp(1101, listop, 1, LISTOP);
79072805 3629
eb160463 3630 listop->op_type = (OPCODE)type;
22c35a8c 3631 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
3632 if (first || last)
3633 flags |= OPf_KIDS;
eb160463 3634 listop->op_flags = (U8)flags;
79072805
LW
3635
3636 if (!last && first)
3637 last = first;
3638 else if (!first && last)
3639 first = last;
8990e307
LW
3640 else if (first)
3641 first->op_sibling = last;
79072805
LW
3642 listop->op_first = first;
3643 listop->op_last = last;
8990e307 3644 if (type == OP_LIST) {
551405c4 3645 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW
3646 pushop->op_sibling = first;
3647 listop->op_first = pushop;
3648 listop->op_flags |= OPf_KIDS;
3649 if (!last)
3650 listop->op_last = pushop;
3651 }
79072805 3652
463d09e6 3653 return CHECKOP(type, listop);
79072805
LW
3654}
3655
d67eb5f4
Z
3656/*
3657=for apidoc Am|OP *|newOP|I32 type|I32 flags
3658
3659Constructs, checks, and returns an op of any base type (any type that
3660has no extra fields). I<type> is the opcode. I<flags> gives the
3661eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3662of C<op_private>.
3663
3664=cut
3665*/
3666
79072805 3667OP *
864dbfa3 3668Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3669{
27da23d5 3670 dVAR;
11343788 3671 OP *o;
e69777c1 3672
7d789282
FC
3673 if (type == -O