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