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