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