This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #96126] Allocate CvFILE more simply
[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;
8990e307 990 SV* sv;
2ebea0a1
GS
991 U8 want;
992
7918f24d
NC
993 PERL_ARGS_ASSERT_SCALARVOID;
994
eb8433b7
NC
995 /* trailing mad null ops don't count as "there" for void processing */
996 if (PL_madskills &&
997 o->op_type != OP_NULL &&
998 o->op_sibling &&
999 o->op_sibling->op_type == OP_NULL)
1000 {
1001 OP *sib;
1002 for (sib = o->op_sibling;
1003 sib && sib->op_type == OP_NULL;
1004 sib = sib->op_sibling) ;
1005
1006 if (!sib)
1007 return o;
1008 }
1009
acb36ea4 1010 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS
1011 || o->op_type == OP_DBSTATE
1012 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1013 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1014 PL_curcop = (COP*)o; /* for warning below */
79072805 1015
54310121 1016 /* assumes no premature commitment */
2ebea0a1 1017 want = o->op_flags & OPf_WANT;
13765c85
DM
1018 if ((want && want != OPf_WANT_SCALAR)
1019 || (PL_parser && PL_parser->error_count)
25b991bf 1020 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1021 {
11343788 1022 return o;
7e363e51 1023 }
79072805 1024
b162f9ea 1025 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1026 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1027 {
b162f9ea 1028 return scalar(o); /* As if inside SASSIGN */
7e363e51 1029 }
1c846c1f 1030
5dc0d613 1031 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1032
11343788 1033 switch (o->op_type) {
79072805 1034 default:
22c35a8c 1035 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1036 break;
36477c24
PP
1037 /* FALL THROUGH */
1038 case OP_REPEAT:
11343788 1039 if (o->op_flags & OPf_STACKED)
8990e307 1040 break;
5d82c453
GA
1041 goto func_ops;
1042 case OP_SUBSTR:
1043 if (o->op_private == 4)
1044 break;
8990e307
LW
1045 /* FALL THROUGH */
1046 case OP_GVSV:
1047 case OP_WANTARRAY:
1048 case OP_GV:
74295f0b 1049 case OP_SMARTMATCH:
8990e307
LW
1050 case OP_PADSV:
1051 case OP_PADAV:
1052 case OP_PADHV:
1053 case OP_PADANY:
1054 case OP_AV2ARYLEN:
8990e307 1055 case OP_REF:
a0d0e21e
LW
1056 case OP_REFGEN:
1057 case OP_SREFGEN:
8990e307
LW
1058 case OP_DEFINED:
1059 case OP_HEX:
1060 case OP_OCT:
1061 case OP_LENGTH:
8990e307
LW
1062 case OP_VEC:
1063 case OP_INDEX:
1064 case OP_RINDEX:
1065 case OP_SPRINTF:
1066 case OP_AELEM:
1067 case OP_AELEMFAST:
93bad3fd 1068 case OP_AELEMFAST_LEX:
8990e307 1069 case OP_ASLICE:
8990e307
LW
1070 case OP_HELEM:
1071 case OP_HSLICE:
1072 case OP_UNPACK:
1073 case OP_PACK:
8990e307
LW
1074 case OP_JOIN:
1075 case OP_LSLICE:
1076 case OP_ANONLIST:
1077 case OP_ANONHASH:
1078 case OP_SORT:
1079 case OP_REVERSE:
1080 case OP_RANGE:
1081 case OP_FLIP:
1082 case OP_FLOP:
1083 case OP_CALLER:
1084 case OP_FILENO:
1085 case OP_EOF:
1086 case OP_TELL:
1087 case OP_GETSOCKNAME:
1088 case OP_GETPEERNAME:
1089 case OP_READLINK:
1090 case OP_TELLDIR:
1091 case OP_GETPPID:
1092 case OP_GETPGRP:
1093 case OP_GETPRIORITY:
1094 case OP_TIME:
1095 case OP_TMS:
1096 case OP_LOCALTIME:
1097 case OP_GMTIME:
1098 case OP_GHBYNAME:
1099 case OP_GHBYADDR:
1100 case OP_GHOSTENT:
1101 case OP_GNBYNAME:
1102 case OP_GNBYADDR:
1103 case OP_GNETENT:
1104 case OP_GPBYNAME:
1105 case OP_GPBYNUMBER:
1106 case OP_GPROTOENT:
1107 case OP_GSBYNAME:
1108 case OP_GSBYPORT:
1109 case OP_GSERVENT:
1110 case OP_GPWNAM:
1111 case OP_GPWUID:
1112 case OP_GGRNAM:
1113 case OP_GGRGID:
1114 case OP_GETLOGIN:
78e1b766 1115 case OP_PROTOTYPE:
5d82c453 1116 func_ops:
64aac5a9 1117 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1118 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1119 useless = OP_DESC(o);
75068674
RGS
1120 break;
1121
1122 case OP_SPLIT:
1123 kid = cLISTOPo->op_first;
1124 if (kid && kid->op_type == OP_PUSHRE
1125#ifdef USE_ITHREADS
1126 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1127#else
1128 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1129#endif
1130 useless = OP_DESC(o);
8990e307
LW
1131 break;
1132
9f82cd5f
YST
1133 case OP_NOT:
1134 kid = cUNOPo->op_first;
1135 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1136 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST
1137 goto func_ops;
1138 }
1139 useless = "negative pattern binding (!~)";
1140 break;
1141
4f4d7508
DC
1142 case OP_SUBST:
1143 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1144 useless = "non-destructive substitution (s///r)";
4f4d7508
DC
1145 break;
1146
bb16bae8
FC
1147 case OP_TRANSR:
1148 useless = "non-destructive transliteration (tr///r)";
1149 break;
1150
8990e307
LW
1151 case OP_RV2GV:
1152 case OP_RV2SV:
1153 case OP_RV2AV:
1154 case OP_RV2HV:
192587c2 1155 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1156 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW
1157 useless = "a variable";
1158 break;
79072805
LW
1159
1160 case OP_CONST:
7766f137 1161 sv = cSVOPo_sv;
7a52d87a
GS
1162 if (cSVOPo->op_private & OPpCONST_STRICT)
1163 no_bareword_allowed(o);
1164 else {
d008e5eb 1165 if (ckWARN(WARN_VOID)) {
fa01e093
RGS
1166 if (SvOK(sv)) {
1167 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1168 "a constant (%"SVf")", sv));
1169 useless = SvPV_nolen(msv);
1170 }
1171 else
1172 useless = "a constant (undef)";
2e0ae2d3 1173 if (o->op_private & OPpCONST_ARYBASE)
d4c19fe8 1174 useless = NULL;
e7fec78e 1175 /* don't warn on optimised away booleans, eg
b5a930ec 1176 * use constant Foo, 5; Foo || print; */
e7fec78e 1177 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1178 useless = NULL;
960b4253
MG
1179 /* the constants 0 and 1 are permitted as they are
1180 conventionally used as dummies in constructs like
1181 1 while some_condition_with_side_effects; */
e7fec78e 1182 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1183 useless = NULL;
d008e5eb 1184 else if (SvPOK(sv)) {
a52fe3ac
A
1185 /* perl4's way of mixing documentation and code
1186 (before the invention of POD) was based on a
1187 trick to mix nroff and perl code. The trick was
1188 built upon these three nroff macros being used in
1189 void context. The pink camel has the details in
1190 the script wrapman near page 319. */
6136c704
AL
1191 const char * const maybe_macro = SvPVX_const(sv);
1192 if (strnEQ(maybe_macro, "di", 2) ||
1193 strnEQ(maybe_macro, "ds", 2) ||
1194 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 1195 useless = NULL;
d008e5eb 1196 }
8990e307
LW
1197 }
1198 }
93c66552 1199 op_null(o); /* don't execute or even remember it */
79072805
LW
1200 break;
1201
1202 case OP_POSTINC:
11343788 1203 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1204 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW
1205 break;
1206
1207 case OP_POSTDEC:
11343788 1208 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1209 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW
1210 break;
1211
679d6c4e
HS
1212 case OP_I_POSTINC:
1213 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1214 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1215 break;
1216
1217 case OP_I_POSTDEC:
1218 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1219 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1220 break;
1221
f2f8fd84
GG
1222 case OP_SASSIGN: {
1223 OP *rv2gv;
1224 UNOP *refgen, *rv2cv;
1225 LISTOP *exlist;
1226
1227 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1228 break;
1229
1230 rv2gv = ((BINOP *)o)->op_last;
1231 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1232 break;
1233
1234 refgen = (UNOP *)((BINOP *)o)->op_first;
1235
1236 if (!refgen || refgen->op_type != OP_REFGEN)
1237 break;
1238
1239 exlist = (LISTOP *)refgen->op_first;
1240 if (!exlist || exlist->op_type != OP_NULL
1241 || exlist->op_targ != OP_LIST)
1242 break;
1243
1244 if (exlist->op_first->op_type != OP_PUSHMARK)
1245 break;
1246
1247 rv2cv = (UNOP*)exlist->op_last;
1248
1249 if (rv2cv->op_type != OP_RV2CV)
1250 break;
1251
1252 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1253 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1254 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1255
1256 o->op_private |= OPpASSIGN_CV_TO_GV;
1257 rv2gv->op_private |= OPpDONT_INIT_GV;
1258 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1259
1260 break;
1261 }
1262
79072805
LW
1263 case OP_OR:
1264 case OP_AND:
edbe35ea
VP
1265 kid = cLOGOPo->op_first;
1266 if (kid->op_type == OP_NOT
1267 && (kid->op_flags & OPf_KIDS)
1268 && !PL_madskills) {
1269 if (o->op_type == OP_AND) {
1270 o->op_type = OP_OR;
1271 o->op_ppaddr = PL_ppaddr[OP_OR];
1272 } else {
1273 o->op_type = OP_AND;
1274 o->op_ppaddr = PL_ppaddr[OP_AND];
1275 }
1276 op_null(kid);
1277 }
1278
c963b151 1279 case OP_DOR:
79072805 1280 case OP_COND_EXPR:
0d863452
RH
1281 case OP_ENTERGIVEN:
1282 case OP_ENTERWHEN:
11343788 1283 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1284 scalarvoid(kid);
1285 break;
5aabfad6 1286
a0d0e21e 1287 case OP_NULL:
11343788 1288 if (o->op_flags & OPf_STACKED)
a0d0e21e 1289 break;
5aabfad6 1290 /* FALL THROUGH */
2ebea0a1
GS
1291 case OP_NEXTSTATE:
1292 case OP_DBSTATE:
79072805
LW
1293 case OP_ENTERTRY:
1294 case OP_ENTER:
11343788 1295 if (!(o->op_flags & OPf_KIDS))
79072805 1296 break;
54310121 1297 /* FALL THROUGH */
463ee0b2 1298 case OP_SCOPE:
79072805
LW
1299 case OP_LEAVE:
1300 case OP_LEAVETRY:
a0d0e21e 1301 case OP_LEAVELOOP:
79072805 1302 case OP_LINESEQ:
79072805 1303 case OP_LIST:
0d863452
RH
1304 case OP_LEAVEGIVEN:
1305 case OP_LEAVEWHEN:
11343788 1306 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1307 scalarvoid(kid);
1308 break;
c90c0ff4 1309 case OP_ENTEREVAL:
5196be3e 1310 scalarkids(o);
c90c0ff4 1311 break;
d6483035 1312 case OP_SCALAR:
5196be3e 1313 return scalar(o);
79072805 1314 }
a2a5de95
NC
1315 if (useless)
1316 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
11343788 1317 return o;
79072805
LW
1318}
1319
1f676739 1320static OP *
412da003 1321S_listkids(pTHX_ OP *o)
79072805 1322{
11343788 1323 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1324 OP *kid;
11343788 1325 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1326 list(kid);
1327 }
11343788 1328 return o;
79072805
LW
1329}
1330
1331OP *
864dbfa3 1332Perl_list(pTHX_ OP *o)
79072805 1333{
27da23d5 1334 dVAR;
79072805
LW
1335 OP *kid;
1336
a0d0e21e 1337 /* assumes no premature commitment */
13765c85
DM
1338 if (!o || (o->op_flags & OPf_WANT)
1339 || (PL_parser && PL_parser->error_count)
5dc0d613 1340 || o->op_type == OP_RETURN)
7e363e51 1341 {
11343788 1342 return o;
7e363e51 1343 }
79072805 1344
b162f9ea 1345 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1346 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1347 {
b162f9ea 1348 return o; /* As if inside SASSIGN */
7e363e51 1349 }
1c846c1f 1350
5dc0d613 1351 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1352
11343788 1353 switch (o->op_type) {
79072805
LW
1354 case OP_FLOP:
1355 case OP_REPEAT:
11343788 1356 list(cBINOPo->op_first);
79072805
LW
1357 break;
1358 case OP_OR:
1359 case OP_AND:
1360 case OP_COND_EXPR:
11343788 1361 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1362 list(kid);
1363 break;
1364 default:
1365 case OP_MATCH:
8782bef2 1366 case OP_QR:
79072805
LW
1367 case OP_SUBST:
1368 case OP_NULL:
11343788 1369 if (!(o->op_flags & OPf_KIDS))
79072805 1370 break;
11343788
MB
1371 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1372 list(cBINOPo->op_first);
1373 return gen_constant_list(o);
79072805
LW
1374 }
1375 case OP_LIST:
11343788 1376 listkids(o);
79072805
LW
1377 break;
1378 case OP_LEAVE:
1379 case OP_LEAVETRY:
5dc0d613 1380 kid = cLISTOPo->op_first;
54310121 1381 list(kid);
25b991bf
VP
1382 kid = kid->op_sibling;
1383 do_kids:
1384 while (kid) {
1385 OP *sib = kid->op_sibling;
c08f093b
VP
1386 if (sib && kid->op_type != OP_LEAVEWHEN)
1387 scalarvoid(kid);
1388 else
54310121 1389 list(kid);
25b991bf 1390 kid = sib;
54310121 1391 }
11206fdd 1392 PL_curcop = &PL_compiling;
54310121 1393 break;
748a9306 1394 case OP_SCOPE:
79072805 1395 case OP_LINESEQ:
25b991bf
VP
1396 kid = cLISTOPo->op_first;
1397 goto do_kids;
79072805 1398 }
11343788 1399 return o;
79072805
LW
1400}
1401
1f676739 1402static OP *
2dd5337b 1403S_scalarseq(pTHX_ OP *o)
79072805 1404{
97aff369 1405 dVAR;
11343788 1406 if (o) {
1496a290
AL
1407 const OPCODE type = o->op_type;
1408
1409 if (type == OP_LINESEQ || type == OP_SCOPE ||
1410 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1411 {
6867be6d 1412 OP *kid;
11343788 1413 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1414 if (kid->op_sibling) {
463ee0b2 1415 scalarvoid(kid);
ed6116ce 1416 }
463ee0b2 1417 }
3280af22 1418 PL_curcop = &PL_compiling;
79072805 1419 }
11343788 1420 o->op_flags &= ~OPf_PARENS;
3280af22 1421 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1422 o->op_flags |= OPf_PARENS;
79072805 1423 }
8990e307 1424 else
11343788
MB
1425 o = newOP(OP_STUB, 0);
1426 return o;
79072805
LW
1427}
1428
76e3520e 1429STATIC OP *
cea2e8a9 1430S_modkids(pTHX_ OP *o, I32 type)
79072805 1431{
11343788 1432 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1433 OP *kid;
11343788 1434 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1435 op_lvalue(kid, type);
79072805 1436 }
11343788 1437 return o;
79072805
LW
1438}
1439
3ad73efd 1440/*
d164302a
GG
1441=for apidoc finalize_optree
1442
1443This function finalizes the optree. Should be called directly after
1444the complete optree is built. It does some additional
1445checking which can't be done in the normal ck_xxx functions and makes
1446the tree thread-safe.
1447
1448=cut
1449*/
1450void
1451Perl_finalize_optree(pTHX_ OP* o)
1452{
1453 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1454
1455 ENTER;
1456 SAVEVPTR(PL_curcop);
1457
1458 finalize_op(o);
1459
1460 LEAVE;
1461}
1462
1463void
1464S_finalize_op(pTHX_ OP* o)
1465{
1466 PERL_ARGS_ASSERT_FINALIZE_OP;
1467
1468#if defined(PERL_MAD) && defined(USE_ITHREADS)
1469 {
1470 /* Make sure mad ops are also thread-safe */
1471 MADPROP *mp = o->op_madprop;
1472 while (mp) {
1473 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1474 OP *prop_op = (OP *) mp->mad_val;
1475 /* We only need "Relocate sv to the pad for thread safety.", but this
1476 easiest way to make sure it traverses everything */
4dc304e0
FC
1477 if (prop_op->op_type == OP_CONST)
1478 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG
1479 finalize_op(prop_op);
1480 }
1481 mp = mp->mad_next;
1482 }
1483 }
1484#endif
1485
1486 switch (o->op_type) {
1487 case OP_NEXTSTATE:
1488 case OP_DBSTATE:
1489 PL_curcop = ((COP*)o); /* for warnings */
1490 break;
1491 case OP_EXEC:
ea31ed66
GG
1492 if ( o->op_sibling
1493 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
d164302a
GG
1494 && ckWARN(WARN_SYNTAX))
1495 {
ea31ed66
GG
1496 if (o->op_sibling->op_sibling) {
1497 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG
1498 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1499 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1500 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG
1501 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1502 "Statement unlikely to be reached");
1503 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1504 "\t(Maybe you meant system() when you said exec()?)\n");
1505 CopLINE_set(PL_curcop, oldline);
1506 }
1507 }
1508 }
1509 break;
1510
1511 case OP_GV:
1512 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1513 GV * const gv = cGVOPo_gv;
1514 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1515 /* XXX could check prototype here instead of just carping */
1516 SV * const sv = sv_newmortal();
1517 gv_efullname3(sv, gv, NULL);
1518 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1519 "%"SVf"() called too early to check prototype",
1520 SVfARG(sv));
1521 }
1522 }
1523 break;
1524
1525 case OP_CONST:
eb796c7f
GG
1526 if (cSVOPo->op_private & OPpCONST_STRICT)
1527 no_bareword_allowed(o);
1528 /* FALLTHROUGH */
d164302a
GG
1529#ifdef USE_ITHREADS
1530 case OP_HINTSEVAL:
1531 case OP_METHOD_NAMED:
1532 /* Relocate sv to the pad for thread safety.
1533 * Despite being a "constant", the SV is written to,
1534 * for reference counts, sv_upgrade() etc. */
1535 if (cSVOPo->op_sv) {
1536 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1537 if (o->op_type != OP_METHOD_NAMED &&
1538 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1539 {
1540 /* If op_sv is already a PADTMP/MY then it is being used by
1541 * some pad, so make a copy. */
1542 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
1543 SvREADONLY_on(PAD_SVl(ix));
1544 SvREFCNT_dec(cSVOPo->op_sv);
1545 }
1546 else if (o->op_type != OP_METHOD_NAMED
1547 && cSVOPo->op_sv == &PL_sv_undef) {
1548 /* PL_sv_undef is hack - it's unsafe to store it in the
1549 AV that is the pad, because av_fetch treats values of
1550 PL_sv_undef as a "free" AV entry and will merrily
1551 replace them with a new SV, causing pad_alloc to think
1552 that this pad slot is free. (When, clearly, it is not)
1553 */
1554 SvOK_off(PAD_SVl(ix));
1555 SvPADTMP_on(PAD_SVl(ix));
1556 SvREADONLY_on(PAD_SVl(ix));
1557 }
1558 else {
1559 SvREFCNT_dec(PAD_SVl(ix));
1560 SvPADTMP_on(cSVOPo->op_sv);
1561 PAD_SETSV(ix, cSVOPo->op_sv);
1562 /* XXX I don't know how this isn't readonly already. */
1563 SvREADONLY_on(PAD_SVl(ix));
1564 }
1565 cSVOPo->op_sv = NULL;
1566 o->op_targ = ix;
1567 }
1568#endif
1569 break;
1570
1571 case OP_HELEM: {
1572 UNOP *rop;
1573 SV *lexname;
1574 GV **fields;
1575 SV **svp, *sv;
1576 const char *key = NULL;
1577 STRLEN keylen;
1578
1579 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1580 break;
1581
1582 /* Make the CONST have a shared SV */
1583 svp = cSVOPx_svp(((BINOP*)o)->op_last);
1584 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
1585 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1586 key = SvPV_const(sv, keylen);
1587 lexname = newSVpvn_share(key,
1588 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1589 0);
1590 SvREFCNT_dec(sv);
1591 *svp = lexname;
1592 }
1593
1594 if ((o->op_private & (OPpLVAL_INTRO)))
1595 break;
1596
1597 rop = (UNOP*)((BINOP*)o)->op_first;
1598 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1599 break;
1600 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1601 if (!SvPAD_TYPED(lexname))
1602 break;
1603 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1604 if (!fields || !GvHV(*fields))
1605 break;
1606 key = SvPV_const(*svp, keylen);
1607 if (!hv_fetch(GvHV(*fields), key,
1608 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1609 Perl_croak(aTHX_ "No such class field \"%s\" "
1610 "in variable %s of type %s",
1611 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
1612 }
1613 break;
1614 }
1615
1616 case OP_HSLICE: {
1617 UNOP *rop;
1618 SV *lexname;
1619 GV **fields;
1620 SV **svp;
1621 const char *key;
1622 STRLEN keylen;
1623 SVOP *first_key_op, *key_op;
1624
1625 if ((o->op_private & (OPpLVAL_INTRO))
1626 /* I bet there's always a pushmark... */
1627 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1628 /* hmmm, no optimization if list contains only one key. */
1629 break;
1630 rop = (UNOP*)((LISTOP*)o)->op_last;
1631 if (rop->op_type != OP_RV2HV)
1632 break;
1633 if (rop->op_first->op_type == OP_PADSV)
1634 /* @$hash{qw(keys here)} */
1635 rop = (UNOP*)rop->op_first;
1636 else {
1637 /* @{$hash}{qw(keys here)} */
1638 if (rop->op_first->op_type == OP_SCOPE
1639 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1640 {
1641 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1642 }
1643 else
1644 break;
1645 }
1646
1647 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1648 if (!SvPAD_TYPED(lexname))
1649 break;
1650 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1651 if (!fields || !GvHV(*fields))
1652 break;
1653 /* Again guessing that the pushmark can be jumped over.... */
1654 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1655 ->op_first->op_sibling;
1656 for (key_op = first_key_op; key_op;
1657 key_op = (SVOP*)key_op->op_sibling) {
1658 if (key_op->op_type != OP_CONST)
1659 continue;
1660 svp = cSVOPx_svp(key_op);
1661 key = SvPV_const(*svp, keylen);
1662 if (!hv_fetch(GvHV(*fields), key,
1663 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
1664 Perl_croak(aTHX_ "No such class field \"%s\" "
1665 "in variable %s of type %s",
1666 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
1667 }
1668 }
1669 break;
1670 }
1671 case OP_SUBST: {
1672 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1673 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1674 break;
1675 }
1676 default:
1677 break;
1678 }
1679
1680 if (o->op_flags & OPf_KIDS) {
1681 OP *kid;
1682 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1683 finalize_op(kid);
1684 }
1685}
1686
1687/*
3ad73efd
Z
1688=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1689
1690Propagate lvalue ("modifiable") context to an op and its children.
1691I<type> represents the context type, roughly based on the type of op that
1692would do the modifying, although C<local()> is represented by OP_NULL,
1693because it has no op type of its own (it is signalled by a flag on
001c3c51
FC
1694the lvalue op).
1695
1696This function detects things that can't be modified, such as C<$x+1>, and
1697generates errors for them. For example, C<$x+1 = 2> would cause it to be
1698called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1699
1700It also flags things that need to behave specially in an lvalue context,
1701such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z
1702
1703=cut
1704*/
ddeae0f1 1705
79072805 1706OP *
d3d7d28f 1707Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 1708{
27da23d5 1709 dVAR;
79072805 1710 OP *kid;
ddeae0f1
DM
1711 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1712 int localize = -1;
79072805 1713
13765c85 1714 if (!o || (PL_parser && PL_parser->error_count))
11343788 1715 return o;
79072805 1716
b162f9ea 1717 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1718 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1719 {
b162f9ea 1720 return o;
7e363e51 1721 }
1c846c1f 1722
5c906035
GG
1723 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1724
11343788 1725 switch (o->op_type) {
68dc0745 1726 case OP_UNDEF:
ddeae0f1 1727 localize = 0;
3280af22 1728 PL_modcount++;
5dc0d613 1729 return o;
a0d0e21e 1730 case OP_CONST:
2e0ae2d3 1731 if (!(o->op_private & OPpCONST_ARYBASE))
a0d0e21e 1732 goto nomod;
54dc0f91 1733 localize = 0;
3280af22 1734 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
fc15ae8f
NC
1735 CopARYBASE_set(&PL_compiling,
1736 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
3280af22 1737 PL_eval_start = 0;
a0d0e21e
LW
1738 }
1739 else if (!type) {
fc15ae8f
NC
1740 SAVECOPARYBASE(&PL_compiling);
1741 CopARYBASE_set(&PL_compiling, 0);
a0d0e21e
LW
1742 }
1743 else if (type == OP_REFGEN)
1744 goto nomod;
1745 else
cea2e8a9 1746 Perl_croak(aTHX_ "That use of $[ is unsupported");
a0d0e21e 1747 break;
5f05dabc 1748 case OP_STUB:
58bde88d 1749 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc
PP
1750 break;
1751 goto nomod;
a0d0e21e 1752 case OP_ENTERSUB:
f79aa60b 1753 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB
1754 !(o->op_flags & OPf_STACKED)) {
1755 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC
1756 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1757 poses, so we need it clear. */
e26df76a 1758 o->op_private &= ~1;
22c35a8c 1759 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1760 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1761 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
1762 break;
1763 }
cd06dffe 1764 else { /* lvalue subroutine call */
777d9014
FC
1765 o->op_private |= OPpLVAL_INTRO
1766 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 1767 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1768 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
cd06dffe
GS
1769 /* Backward compatibility mode: */
1770 o->op_private |= OPpENTERSUB_INARGS;
1771 break;
1772 }
1773 else { /* Compile-time error message: */
1774 OP *kid = cUNOPo->op_first;
1775 CV *cv;
1776 OP *okid;
1777
3ea285d1
AL
1778 if (kid->op_type != OP_PUSHMARK) {
1779 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1780 Perl_croak(aTHX_
1781 "panic: unexpected lvalue entersub "
1782 "args: type/targ %ld:%"UVuf,
1783 (long)kid->op_type, (UV)kid->op_targ);
1784 kid = kLISTOP->op_first;
1785 }
cd06dffe
GS
1786 while (kid->op_sibling)
1787 kid = kid->op_sibling;
1788 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1789 /* Indirect call */
1790 if (kid->op_type == OP_METHOD_NAMED
1791 || kid->op_type == OP_METHOD)
1792 {
87d7fd28 1793 UNOP *newop;
b2ffa427 1794
87d7fd28 1795 NewOp(1101, newop, 1, UNOP);
349fd7b7
GS
1796 newop->op_type = OP_RV2CV;
1797 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
5f66b61c 1798 newop->op_first = NULL;
87d7fd28
GS
1799 newop->op_next = (OP*)newop;
1800 kid->op_sibling = (OP*)newop;
349fd7b7 1801 newop->op_private |= OPpLVAL_INTRO;
e26df76a 1802 newop->op_private &= ~1;
cd06dffe
GS
1803 break;
1804 }
b2ffa427 1805
cd06dffe
GS
1806 if (kid->op_type != OP_RV2CV)
1807 Perl_croak(aTHX_
1808 "panic: unexpected lvalue entersub "
55140b79 1809 "entry via type/targ %ld:%"UVuf,
3d811634 1810 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1811 kid->op_private |= OPpLVAL_INTRO;
1812 break; /* Postpone until runtime */
1813 }
b2ffa427
NIS
1814
1815 okid = kid;
cd06dffe
GS
1816 kid = kUNOP->op_first;
1817 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1818 kid = kUNOP->op_first;
b2ffa427 1819 if (kid->op_type == OP_NULL)
cd06dffe
GS
1820 Perl_croak(aTHX_
1821 "Unexpected constant lvalue entersub "
55140b79 1822 "entry via type/targ %ld:%"UVuf,
3d811634 1823 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe
GS
1824 if (kid->op_type != OP_GV) {
1825 /* Restore RV2CV to check lvalueness */
1826 restore_2cv:
1827 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1828 okid->op_next = kid->op_next;
1829 kid->op_next = okid;
1830 }
1831 else
5f66b61c 1832 okid->op_next = NULL;
cd06dffe
GS
1833 okid->op_type = OP_RV2CV;
1834 okid->op_targ = 0;
1835 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1836 okid->op_private |= OPpLVAL_INTRO;
e26df76a 1837 okid->op_private &= ~1;
cd06dffe
GS
1838 break;
1839 }
b2ffa427 1840
638eceb6 1841 cv = GvCV(kGVOP_gv);
1c846c1f 1842 if (!cv)
cd06dffe
GS
1843 goto restore_2cv;
1844 if (CvLVALUE(cv))
1845 break;
1846 }
1847 }
79072805
LW
1848 /* FALL THROUGH */
1849 default:
a0d0e21e 1850 nomod:
f5d552b4 1851 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 1852 /* grep, foreach, subcalls, refgen */
145b2bbb
FC
1853 if (type == OP_GREPSTART || type == OP_ENTERSUB
1854 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 1855 break;
cea2e8a9 1856 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 1857 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
1858 ? "do block"
1859 : (o->op_type == OP_ENTERSUB
1860 ? "non-lvalue subroutine call"
53e06cf0 1861 : OP_DESC(o))),
22c35a8c 1862 type ? PL_op_desc[type] : "local"));
11343788 1863 return o;
79072805 1864
a0d0e21e
LW
1865 case OP_PREINC:
1866 case OP_PREDEC:
1867 case OP_POW:
1868 case OP_MULTIPLY:
1869 case OP_DIVIDE:
1870 case OP_MODULO:
1871 case OP_REPEAT:
1872 case OP_ADD:
1873 case OP_SUBTRACT:
1874 case OP_CONCAT:
1875 case OP_LEFT_SHIFT:
1876 case OP_RIGHT_SHIFT:
1877 case OP_BIT_AND:
1878 case OP_BIT_XOR:
1879 case OP_BIT_OR:
1880 case OP_I_MULTIPLY:
1881 case OP_I_DIVIDE:
1882 case OP_I_MODULO:
1883 case OP_I_ADD:
1884 case OP_I_SUBTRACT:
11343788 1885 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 1886 goto nomod;
3280af22 1887 PL_modcount++;
a0d0e21e 1888 break;
b2ffa427 1889
79072805 1890 case OP_COND_EXPR:
ddeae0f1 1891 localize = 1;
11343788 1892 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 1893 op_lvalue(kid, type);
79072805
LW
1894 break;
1895
1896 case OP_RV2AV:
1897 case OP_RV2HV:
11343788 1898 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 1899 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 1900 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW
1901 }
1902 /* FALL THROUGH */
79072805 1903 case OP_RV2GV:
5dc0d613 1904 if (scalar_mod_type(o, type))
3fe9a6f1 1905 goto nomod;
11343788 1906 ref(cUNOPo->op_first, o->op_type);
79072805 1907 /* FALL THROUGH */
79072805
LW
1908 case OP_ASLICE:
1909 case OP_HSLICE:
78f9721b
SM
1910 if (type == OP_LEAVESUBLV)
1911 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1912 localize = 1;
78f9721b
SM
1913 /* FALL THROUGH */
1914 case OP_AASSIGN:
93a17b20
LW
1915 case OP_NEXTSTATE:
1916 case OP_DBSTATE:
e6438c1a 1917 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 1918 break;
28c5b5bc
RGS
1919 case OP_AV2ARYLEN:
1920 PL_hints |= HINT_BLOCK_SCOPE;
1921 if (type == OP_LEAVESUBLV)
1922 o->op_private |= OPpMAYBE_LVSUB;
1923 PL_modcount++;
1924 break;
463ee0b2 1925 case OP_RV2SV:
aeea060c 1926 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 1927 localize = 1;
463ee0b2 1928 /* FALL THROUGH */
79072805 1929 case OP_GV:
3280af22 1930 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 1931 case OP_SASSIGN:
bf4b1e52
GS
1932 case OP_ANDASSIGN:
1933 case OP_ORASSIGN:
c963b151 1934 case OP_DORASSIGN:
ddeae0f1
DM
1935 PL_modcount++;
1936 break;
1937
8990e307 1938 case OP_AELEMFAST:
93bad3fd 1939 case OP_AELEMFAST_LEX:
6a077020 1940 localize = -1;
3280af22 1941 PL_modcount++;
8990e307
LW
1942 break;
1943
748a9306
LW
1944 case OP_PADAV:
1945 case OP_PADHV:
e6438c1a 1946 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
1947 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1948 return o; /* Treat \(@foo) like ordinary list. */
1949 if (scalar_mod_type(o, type))
3fe9a6f1 1950 goto nomod;
78f9721b
SM
1951 if (type == OP_LEAVESUBLV)
1952 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW
1953 /* FALL THROUGH */
1954 case OP_PADSV:
3280af22 1955 PL_modcount++;
ddeae0f1 1956 if (!type) /* local() */
5ede95a0
BF
1957 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
1958 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW
1959 break;
1960
748a9306 1961 case OP_PUSHMARK:
ddeae0f1 1962 localize = 0;
748a9306 1963 break;
b2ffa427 1964
69969c6f 1965 case OP_KEYS:
d8065907 1966 case OP_RKEYS:
fad4a2e4 1967 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 1968 goto nomod;
5d82c453
GA
1969 goto lvalue_func;
1970 case OP_SUBSTR:
1971 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1972 goto nomod;
5f05dabc 1973 /* FALL THROUGH */
a0d0e21e 1974 case OP_POS:
463ee0b2 1975 case OP_VEC:
fad4a2e4 1976 lvalue_func:
78f9721b
SM
1977 if (type == OP_LEAVESUBLV)
1978 o->op_private |= OPpMAYBE_LVSUB;
11343788
MB
1979 pad_free(o->op_targ);
1980 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 1981 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788 1982 if (o->op_flags & OPf_KIDS)
3ad73efd 1983 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 1984 break;
a0d0e21e 1985
463ee0b2
LW
1986 case OP_AELEM:
1987 case OP_HELEM:
11343788 1988 ref(cBINOPo->op_first, o->op_type);
68dc0745 1989 if (type == OP_ENTERSUB &&
5dc0d613
MB
1990 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1991 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
1992 if (type == OP_LEAVESUBLV)
1993 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 1994 localize = 1;
3280af22 1995 PL_modcount++;
463ee0b2
LW
1996 break;
1997
1998 case OP_SCOPE:
1999 case OP_LEAVE:
2000 case OP_ENTER:
78f9721b 2001 case OP_LINESEQ:
ddeae0f1 2002 localize = 0;
11343788 2003 if (o->op_flags & OPf_KIDS)
3ad73efd 2004 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW
2005 break;
2006
2007 case OP_NULL:
ddeae0f1 2008 localize = 0;
638bc118
GS
2009 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2010 goto nomod;
2011 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2012 break;
11343788 2013 if (o->op_targ != OP_LIST) {
3ad73efd 2014 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW
2015 break;
2016 }
2017 /* FALL THROUGH */
463ee0b2 2018 case OP_LIST:
ddeae0f1 2019 localize = 0;
11343788 2020 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG
2021 /* elements might be in void context because the list is
2022 in scalar context or because they are attribute sub calls */
2023 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2024 op_lvalue(kid, type);
463ee0b2 2025 break;
78f9721b
SM
2026
2027 case OP_RETURN:
2028 if (type != OP_LEAVESUBLV)
2029 goto nomod;
3ad73efd 2030 break; /* op_lvalue()ing was handled by ck_return() */
463ee0b2 2031 }
58d95175 2032
8be1be90
AMS
2033 /* [20011101.069] File test operators interpret OPf_REF to mean that
2034 their argument is a filehandle; thus \stat(".") should not set
2035 it. AMS 20011102 */
2036 if (type == OP_REFGEN &&
ef69c8fc 2037 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS
2038 return o;
2039
2040 if (type != OP_LEAVESUBLV)
2041 o->op_flags |= OPf_MOD;
2042
2043 if (type == OP_AASSIGN || type == OP_SASSIGN)
2044 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM
2045 else if (!type) { /* local() */
2046 switch (localize) {
2047 case 1:
2048 o->op_private |= OPpLVAL_INTRO;
2049 o->op_flags &= ~OPf_SPECIAL;
2050 PL_hints |= HINT_BLOCK_SCOPE;
2051 break;
2052 case 0:
2053 break;
2054 case -1:
a2a5de95
NC
2055 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2056 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2057 }
463ee0b2 2058 }
8be1be90
AMS
2059 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2060 && type != OP_LEAVESUBLV)
2061 o->op_flags |= OPf_REF;
11343788 2062 return o;
463ee0b2
LW
2063}
2064
864dbfa3 2065STATIC bool
5f66b61c 2066S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2067{
1ecbeecf 2068 assert(o || type != OP_SASSIGN);
7918f24d 2069
3fe9a6f1
PP
2070 switch (type) {
2071 case OP_SASSIGN:
5196be3e 2072 if (o->op_type == OP_RV2GV)
3fe9a6f1
PP
2073 return FALSE;
2074 /* FALL THROUGH */
2075 case OP_PREINC:
2076 case OP_PREDEC:
2077 case OP_POSTINC:
2078 case OP_POSTDEC:
2079 case OP_I_PREINC:
2080 case OP_I_PREDEC:
2081 case OP_I_POSTINC:
2082 case OP_I_POSTDEC:
2083 case OP_POW:
2084 case OP_MULTIPLY:
2085 case OP_DIVIDE:
2086 case OP_MODULO:
2087 case OP_REPEAT:
2088 case OP_ADD:
2089 case OP_SUBTRACT:
2090 case OP_I_MULTIPLY:
2091 case OP_I_DIVIDE:
2092 case OP_I_MODULO:
2093 case OP_I_ADD:
2094 case OP_I_SUBTRACT:
2095 case OP_LEFT_SHIFT:
2096 case OP_RIGHT_SHIFT:
2097 case OP_BIT_AND:
2098 case OP_BIT_XOR:
2099 case OP_BIT_OR:
2100 case OP_CONCAT:
2101 case OP_SUBST:
2102 case OP_TRANS:
bb16bae8 2103 case OP_TRANSR:
49e9fbe6
GS
2104 case OP_READ:
2105 case OP_SYSREAD:
2106 case OP_RECV:
bf4b1e52
GS
2107 case OP_ANDASSIGN:
2108 case OP_ORASSIGN:
410d09fe 2109 case OP_DORASSIGN:
3fe9a6f1
PP
2110 return TRUE;
2111 default:
2112 return FALSE;
2113 }
2114}
2115
35cd451c 2116STATIC bool
5f66b61c 2117S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2118{
7918f24d
NC
2119 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2120
35cd451c
GS
2121 switch (o->op_type) {
2122 case OP_PIPE_OP:
2123 case OP_SOCKPAIR:
504618e9 2124 if (numargs == 2)
35cd451c
GS
2125 return TRUE;
2126 /* FALL THROUGH */
2127 case OP_SYSOPEN:
2128 case OP_OPEN:
ded8aa31 2129 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
2130 case OP_SOCKET:
2131 case OP_OPEN_DIR:
2132 case OP_ACCEPT:
504618e9 2133 if (numargs == 1)
35cd451c 2134 return TRUE;
5f66b61c 2135 /* FALLTHROUGH */
35cd451c
GS
2136 default:
2137 return FALSE;
2138 }
2139}
2140
0d86688d
NC
2141static OP *
2142S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2143{
11343788 2144 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2145 OP *kid;
11343788 2146 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
2147 ref(kid, type);
2148 }
11343788 2149 return o;
463ee0b2
LW
2150}
2151
2152OP *
e4c5ccf3 2153Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2154{
27da23d5 2155 dVAR;
463ee0b2 2156 OP *kid;
463ee0b2 2157
7918f24d
NC
2158 PERL_ARGS_ASSERT_DOREF;
2159
13765c85 2160 if (!o || (PL_parser && PL_parser->error_count))
11343788 2161 return o;
463ee0b2 2162
11343788 2163 switch (o->op_type) {
a0d0e21e 2164 case OP_ENTERSUB:
f4df43b5 2165 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB
2166 !(o->op_flags & OPf_STACKED)) {
2167 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2168 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2169 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2170 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2171 o->op_flags |= OPf_SPECIAL;
e26df76a 2172 o->op_private &= ~1;
8990e307 2173 }
767eda44
FC
2174 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2175 o->op_private |= OPpENTERSUB_DEREF;
2176 o->op_flags |= OPf_MOD;
2177 }
2178
8990e307 2179 break;
aeea060c 2180
463ee0b2 2181 case OP_COND_EXPR:
11343788 2182 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2183 doref(kid, type, set_op_ref);
463ee0b2 2184 break;
8990e307 2185 case OP_RV2SV:
35cd451c
GS
2186 if (type == OP_DEFINED)
2187 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2188 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW
2189 /* FALL THROUGH */
2190 case OP_PADSV:
5f05dabc 2191 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
2192 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2193 : type == OP_RV2HV ? OPpDEREF_HV
2194 : OPpDEREF_SV);
11343788 2195 o->op_flags |= OPf_MOD;
a0d0e21e 2196 }
8990e307 2197 break;
1c846c1f 2198
463ee0b2
LW
2199 case OP_RV2AV:
2200 case OP_RV2HV:
e4c5ccf3
RH
2201 if (set_op_ref)
2202 o->op_flags |= OPf_REF;
8990e307 2203 /* FALL THROUGH */
463ee0b2 2204 case OP_RV2GV:
35cd451c
GS
2205 if (type == OP_DEFINED)
2206 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2207 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2208 break;
8990e307 2209
463ee0b2
LW
2210 case OP_PADAV:
2211 case OP_PADHV:
e4c5ccf3
RH
2212 if (set_op_ref)
2213 o->op_flags |= OPf_REF;
79072805 2214 break;
aeea060c 2215
8990e307 2216 case OP_SCALAR:
79072805 2217 case OP_NULL:
11343788 2218 if (!(o->op_flags & OPf_KIDS))
463ee0b2 2219 break;
e4c5ccf3 2220 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW
2221 break;
2222 case OP_AELEM:
2223 case OP_HELEM:
e4c5ccf3 2224 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2225 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
2226 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2227 : type == OP_RV2HV ? OPpDEREF_HV
2228 : OPpDEREF_SV);
11343788 2229 o->op_flags |= OPf_MOD;
8990e307 2230 }
79072805
LW
2231 break;
2232
463ee0b2 2233 case OP_SCOPE:
79072805 2234 case OP_LEAVE:
e4c5ccf3
RH
2235 set_op_ref = FALSE;
2236 /* FALL THROUGH */
79072805 2237 case OP_ENTER:
8990e307 2238 case OP_LIST:
11343788 2239 if (!(o->op_flags & OPf_KIDS))
79072805 2240 break;
e4c5ccf3 2241 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2242 break;
a0d0e21e
LW
2243 default:
2244 break;
79072805 2245 }
11343788 2246 return scalar(o);
8990e307 2247
79072805
LW
2248}
2249
09bef843
SB
2250STATIC OP *
2251S_dup_attrlist(pTHX_ OP *o)
2252{
97aff369 2253 dVAR;
0bd48802 2254 OP *rop;
09bef843 2255
7918f24d
NC
2256 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2257
09bef843
SB
2258 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2259 * where the first kid is OP_PUSHMARK and the remaining ones
2260 * are OP_CONST. We need to push the OP_CONST values.
2261 */
2262 if (o->op_type == OP_CONST)
b37c2d43 2263 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC
2264#ifdef PERL_MAD
2265 else if (o->op_type == OP_NULL)
1d866c12 2266 rop = NULL;
eb8433b7 2267#endif
09bef843
SB
2268 else {
2269 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2270 rop = NULL;
09bef843
SB
2271 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2272 if (o->op_type == OP_CONST)
2fcb4757 2273 rop = op_append_elem(OP_LIST, rop,
09bef843 2274 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2275 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB
2276 }
2277 }
2278 return rop;
2279}
2280
2281STATIC void
95f0a2f1 2282S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 2283{
27da23d5 2284 dVAR;
09bef843
SB
2285 SV *stashsv;
2286
7918f24d
NC
2287 PERL_ARGS_ASSERT_APPLY_ATTRS;
2288
09bef843
SB
2289 /* fake up C<use attributes $pkg,$rv,@attrs> */
2290 ENTER; /* need to protect against side-effects of 'use' */
5aaec2b4 2291 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 2292
09bef843 2293#define ATTRSMODULE "attributes"
95f0a2f1
SB
2294#define ATTRSMODULE_PM "attributes.pm"
2295
2296 if (for_my) {
95f0a2f1 2297 /* Don't force the C<use> if we don't need it. */
a4fc7abc 2298 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 2299 if (svp && *svp != &PL_sv_undef)
6f207bd3 2300 NOOP; /* already in %INC */
95f0a2f1
SB
2301 else
2302 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 2303 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB
2304 }
2305 else {
2306 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL
2307 newSVpvs(ATTRSMODULE),
2308 NULL,
2fcb4757 2309 op_prepend_elem(OP_LIST,
95f0a2f1 2310 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2311 op_prepend_elem(OP_LIST,
95f0a2f1
SB
2312 newSVOP(OP_CONST, 0,
2313 newRV(target)),
2314 dup_attrlist(attrs))));
2315 }
09bef843
SB
2316 LEAVE;
2317}
2318
95f0a2f1
SB
2319STATIC void
2320S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2321{
97aff369 2322 dVAR;
95f0a2f1
SB
2323 OP *pack, *imop, *arg;
2324 SV *meth, *stashsv;
2325
7918f24d
NC
2326 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2327
95f0a2f1
SB
2328 if (!attrs)
2329 return;
2330
2331 assert(target->op_type == OP_PADSV ||
2332 target->op_type == OP_PADHV ||
2333 target->op_type == OP_PADAV);
2334
2335 /* Ensure that attributes.pm is loaded. */
dd2155a4 2336 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB
2337
2338 /* Need package name for method call. */
6136c704 2339 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB
2340
2341 /* Build up the real arg-list. */
5aaec2b4
NC
2342 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2343
95f0a2f1
SB
2344 arg = newOP(OP_PADSV, 0);
2345 arg->op_targ = target->op_targ;
2fcb4757 2346 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2347 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2348 op_prepend_elem(OP_LIST,
95f0a2f1 2349 newUNOP(OP_REFGEN, 0,
3ad73efd 2350 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB
2351 dup_attrlist(attrs)));
2352
2353 /* Fake up a method call to import */
18916d0d 2354 meth = newSVpvs_share("import");
95f0a2f1 2355 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z
2356 op_append_elem(OP_LIST,
2357 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2358 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB
2359
2360 /* Combine the ops. */
2fcb4757 2361 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB
2362}
2363
2364/*
2365=notfor apidoc apply_attrs_string
2366
2367Attempts to apply a list of attributes specified by the C<attrstr> and
2368C<len> arguments to the subroutine identified by the C<cv> argument which
2369is expected to be associated with the package identified by the C<stashpv>
2370argument (see L<attributes>). It gets this wrong, though, in that it
2371does not correctly identify the boundaries of the individual attribute
2372specifications within C<attrstr>. This is not really intended for the
2373public API, but has to be listed here for systems such as AIX which
2374need an explicit export list for symbols. (It's called from XS code
2375in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2376to respect attribute syntax properly would be welcome.
2377
2378=cut
2379*/
2380
be3174d2 2381void
6867be6d
AL
2382Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2383 const char *attrstr, STRLEN len)
be3174d2 2384{
5f66b61c 2385 OP *attrs = NULL;
be3174d2 2386
7918f24d
NC
2387 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2388
be3174d2
GS
2389 if (!len) {
2390 len = strlen(attrstr);
2391 }
2392
2393 while (len) {
2394 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2395 if (len) {
890ce7af 2396 const char * const sstr = attrstr;
be3174d2 2397 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2398 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS
2399 newSVOP(OP_CONST, 0,
2400 newSVpvn(sstr, attrstr-sstr)));
2401 }
2402 }
2403
2404 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2405 newSVpvs(ATTRSMODULE),
2fcb4757 2406 NULL, op_prepend_elem(OP_LIST,
be3174d2 2407 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2408 op_prepend_elem(OP_LIST,
be3174d2 2409 newSVOP(OP_CONST, 0,
ad64d0ec 2410 newRV(MUTABLE_SV(cv))),
be3174d2
GS
2411 attrs)));
2412}
2413
09bef843 2414STATIC OP *
95f0a2f1 2415S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2416{
97aff369 2417 dVAR;
93a17b20 2418 I32 type;
a1fba7eb 2419 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2420
7918f24d
NC
2421 PERL_ARGS_ASSERT_MY_KID;
2422
13765c85 2423 if (!o || (PL_parser && PL_parser->error_count))
11343788 2424 return o;
93a17b20 2425
bc61e325 2426 type = o->op_type;
eb8433b7
NC
2427 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2428 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2429 return o;
2430 }
2431
93a17b20 2432 if (type == OP_LIST) {
6867be6d 2433 OP *kid;
11343788 2434 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2435 my_kid(kid, attrs, imopsp);
eb8433b7
NC
2436 } else if (type == OP_UNDEF
2437#ifdef PERL_MAD
2438 || type == OP_STUB
2439#endif
2440 ) {
7766148a 2441 return o;
77ca0c92
LW
2442 } else if (type == OP_RV2SV || /* "our" declaration */
2443 type == OP_RV2AV ||
2444 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2445 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2446 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2447 OP_DESC(o),
12bd6ede
DM
2448 PL_parser->in_my == KEY_our
2449 ? "our"
2450 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2451 } else if (attrs) {
551405c4 2452 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM
2453 PL_parser->in_my = FALSE;
2454 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS
2455 apply_attrs(GvSTASH(gv),
2456 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC
2457 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2458 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
1ce0b88c
RGS
2459 attrs, FALSE);
2460 }
192587c2 2461 o->op_private |= OPpOUR_INTRO;
77ca0c92 2462 return o;
95f0a2f1
SB
2463 }
2464 else if (type != OP_PADSV &&
93a17b20
LW
2465 type != OP_PADAV &&
2466 type != OP_PADHV &&
2467 type != OP_PUSHMARK)
2468 {
eb64745e 2469 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2470 OP_DESC(o),
12bd6ede
DM
2471 PL_parser->in_my == KEY_our
2472 ? "our"
2473 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2474 return o;
93a17b20 2475 }
09bef843
SB
2476 else if (attrs && type != OP_PUSHMARK) {
2477 HV *stash;
09bef843 2478
12bd6ede
DM
2479 PL_parser->in_my = FALSE;
2480 PL_parser->in_my_stash = NULL;
eb64745e 2481
09bef843 2482 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM
2483 stash = PAD_COMPNAME_TYPE(o->op_targ);
2484 if (!stash)
09bef843 2485 stash = PL_curstash;
95f0a2f1 2486 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2487 }
11343788
MB
2488 o->op_flags |= OPf_MOD;
2489 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2490 if (stately)
952306ac 2491 o->op_private |= OPpPAD_STATE;
11343788 2492 return o;
93a17b20
LW
2493}
2494
2495OP *
09bef843
SB
2496Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2497{
97aff369 2498 dVAR;
0bd48802 2499 OP *rops;
95f0a2f1
SB
2500 int maybe_scalar = 0;
2501
7918f24d
NC
2502 PERL_ARGS_ASSERT_MY_ATTRS;
2503
d2be0de5 2504/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2505 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2506#if 0
09bef843
SB
2507 if (o->op_flags & OPf_PARENS)
2508 list(o);
95f0a2f1
SB
2509 else
2510 maybe_scalar = 1;
d2be0de5
YST
2511#else
2512 maybe_scalar = 1;
2513#endif
09bef843
SB
2514 if (attrs)
2515 SAVEFREEOP(attrs);
5f66b61c 2516 rops = NULL;
95f0a2f1
SB
2517 o = my_kid(o, attrs, &rops);
2518 if (rops) {
2519 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2520 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB
2521 o->op_private |= OPpLVAL_INTRO;
2522 }
f5d1ed10
FC
2523 else {
2524 /* The listop in rops might have a pushmark at the beginning,
2525 which will mess up list assignment. */
2526 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2527 if (rops->op_type == OP_LIST &&
2528 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2529 {
2530 OP * const pushmark = lrops->op_first;
2531 lrops->op_first = pushmark->op_sibling;
2532 op_free(pushmark);
2533 }
2fcb4757 2534 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2535 }
95f0a2f1 2536 }
12bd6ede
DM
2537 PL_parser->in_my = FALSE;
2538 PL_parser->in_my_stash = NULL;
eb64745e 2539 return o;
09bef843
SB
2540}
2541
2542OP *
864dbfa3 2543Perl_sawparens(pTHX_ OP *o)
79072805 2544{
96a5add6 2545 PERL_UNUSED_CONTEXT;
79072805
LW
2546 if (o)
2547 o->op_flags |= OPf_PARENS;
2548 return o;
2549}
2550
2551OP *
864dbfa3 2552Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2553{
11343788 2554 OP *o;
59f00321 2555 bool ismatchop = 0;
1496a290
AL
2556 const OPCODE ltype = left->op_type;
2557 const OPCODE rtype = right->op_type;
79072805 2558
7918f24d
NC
2559 PERL_ARGS_ASSERT_BIND_MATCH;
2560
1496a290
AL
2561 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2562 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2563 {
1496a290 2564 const char * const desc
bb16bae8
FC
2565 = PL_op_desc[(
2566 rtype == OP_SUBST || rtype == OP_TRANS
2567 || rtype == OP_TRANSR
2568 )
666ea192
JH
2569 ? (int)rtype : OP_MATCH];
2570 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2571 ? "@array" : "%hash");
9014280d 2572 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2573 "Applying %s to %s will act on scalar(%s)",
599cee73 2574 desc, sample, sample);
2ae324a7
PP
2575 }
2576
1496a290 2577 if (rtype == OP_CONST &&
5cc9e5c9
RH
2578 cSVOPx(right)->op_private & OPpCONST_BARE &&
2579 cSVOPx(right)->op_private & OPpCONST_STRICT)
2580 {
2581 no_bareword_allowed(right);
2582 }
2583
bb16bae8 2584 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC
2585 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2586 type == OP_NOT)
2587 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC
2588 if (rtype == OP_TRANSR && type == OP_NOT)
2589 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2590
2474a784
FC
2591 ismatchop = (rtype == OP_MATCH ||
2592 rtype == OP_SUBST ||
bb16bae8 2593 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2594 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS
2595 if (ismatchop && right->op_private & OPpTARGET_MY) {
2596 right->op_targ = 0;
2597 right->op_private &= ~OPpTARGET_MY;
2598 }
2599 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL
2600 OP *newleft;
2601
79072805 2602 right->op_flags |= OPf_STACKED;
bb16bae8 2603 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2604 ! (rtype == OP_TRANS &&
4f4d7508
DC
2605 right->op_private & OPpTRANS_IDENTICAL) &&
2606 ! (rtype == OP_SUBST &&
2607 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2608 newleft = op_lvalue(left, rtype);
1496a290
AL
2609 else
2610 newleft = left;
bb16bae8 2611 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2612 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2613 else
2fcb4757 2614 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2615 if (type == OP_NOT)
11343788
MB
2616 return newUNOP(OP_NOT, 0, scalar(o));
2617 return o;
79072805
LW
2618 }
2619 else
2620 return bind_match(type, left,
131b3ad0 2621 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW
2622}
2623
2624OP *
864dbfa3 2625Perl_invert(pTHX_ OP *o)
79072805 2626{
11343788 2627 if (!o)
1d866c12 2628 return NULL;
11343788 2629 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
2630}
2631
3ad73efd
Z
2632/*
2633=for apidoc Amx|OP *|op_scope|OP *o
2634
2635Wraps up an op tree with some additional ops so that at runtime a dynamic
2636scope will be created. The original ops run in the new dynamic scope,
2637and then, provided that they exit normally, the scope will be unwound.
2638The additional ops used to create and unwind the dynamic scope will
2639normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2640instead if the ops are simple enough to not need the full dynamic scope
2641structure.
2642
2643=cut
2644*/
2645
79072805 2646OP *
3ad73efd 2647Perl_op_scope(pTHX_ OP *o)
79072805 2648{
27da23d5 2649 dVAR;
79072805 2650 if (o) {
3280af22 2651 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2fcb4757 2652 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2653 o->op_type = OP_LEAVE;
22c35a8c 2654 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2655 }
fdb22418
HS
2656 else if (o->op_type == OP_LINESEQ) {
2657 OP *kid;
2658 o->op_type = OP_SCOPE;
2659 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2660 kid = ((LISTOP*)o)->op_first;
59110972 2661 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2662 op_null(kid);
59110972
RH
2663
2664 /* The following deals with things like 'do {1 for 1}' */
2665 kid = kid->op_sibling;
2666 if (kid &&
2667 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2668 op_null(kid);
2669 }
463ee0b2 2670 }
fdb22418 2671 else
5f66b61c 2672 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW
2673 }
2674 return o;
2675}
1930840b 2676
a0d0e21e 2677int
864dbfa3 2678Perl_block_start(pTHX_ int full)
79072805 2679{
97aff369 2680 dVAR;
73d840c0 2681 const int retval = PL_savestack_ix;
1930840b 2682
dd2155a4 2683 pad_block_start(full);
b3ac6de7 2684 SAVEHINTS();
3280af22 2685 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2686 SAVECOMPILEWARNINGS();
72dc9ed5 2687 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2688
a88d97bf 2689 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2690
a0d0e21e
LW
2691 return retval;
2692}
2693
2694OP*
864dbfa3 2695Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2696{
97aff369 2697 dVAR;
6867be6d 2698 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b
BM
2699 OP* retval = scalarseq(seq);
2700
a88d97bf 2701 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2702
e9818f4e 2703 LEAVE_SCOPE(floor);
623e6609 2704 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2705 if (needblockscope)
3280af22 2706 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2707 pad_leavemy();
1930840b 2708
a88d97bf 2709 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2710
a0d0e21e
LW
2711 return retval;
2712}
2713
fd85fad2
BM
2714/*
2715=head1 Compile-time scope hooks
2716
3e4ddde5 2717=for apidoc Aox||blockhook_register
fd85fad2
BM
2718
2719Register a set of hooks to be called when the Perl lexical scope changes
2720at compile time. See L<perlguts/"Compile-time scope hooks">.
2721
2722=cut
2723*/
2724
bb6c22e7
BM
2725void
2726Perl_blockhook_register(pTHX_ BHK *hk)
2727{
2728 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2729
2730 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2731}
2732
76e3520e 2733STATIC OP *
cea2e8a9 2734S_newDEFSVOP(pTHX)
54b9620d 2735{
97aff369 2736 dVAR;
cc76b5cc 2737 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 2738 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS
2739 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2740 }
2741 else {
551405c4 2742 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS
2743 o->op_targ = offset;
2744 return o;
2745 }
54b9620d
MB
2746}
2747
a0d0e21e 2748void
864dbfa3 2749Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2750{
97aff369 2751 dVAR;
7918f24d
NC
2752
2753 PERL_ARGS_ASSERT_NEWPROG;
2754
3280af22 2755 if (PL_in_eval) {
86a64801 2756 PERL_CONTEXT *cx;
b295d113
TH
2757 if (PL_eval_root)
2758 return;
faef0170
HS
2759 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2760 ((PL_in_eval & EVAL_KEEPERR)
2761 ? OPf_SPECIAL : 0), o);
86a64801
GG
2762
2763 cx = &cxstack[cxstack_ix];
2764 assert(CxTYPE(cx) == CXt_EVAL);
2765
2766 if ((cx->blk_gimme & G_WANT) == G_VOID)
2767 scalarvoid(PL_eval_root);
2768 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2769 list(PL_eval_root);
2770 else
2771 scalar(PL_eval_root);
2772
5983a79d
BM
2773 /* don't use LINKLIST, since PL_eval_root might indirect through
2774 * a rather expensive function call and LINKLIST evaluates its
2775 * argument more than once */
2776 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS
2777 PL_eval_root->op_private |= OPpREFCOUNTED;
2778 OpREFCNT_set(PL_eval_root, 1);
3280af22 2779 PL_eval_root->op_next = 0;
a2efc822 2780 CALL_PEEP(PL_eval_start);
86a64801
GG
2781 finalize_optree(PL_eval_root);
2782
a0d0e21e
LW
2783 }
2784 else {
6be89cf9
AE
2785 if (o->op_type == OP_STUB) {
2786 PL_comppad_name = 0;
2787 PL_compcv = 0;
d2c837a0 2788 S_op_destroy(aTHX_ o);
a0d0e21e 2789 return;
6be89cf9 2790 }
3ad73efd 2791 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS
2792 PL_curcop = &PL_compiling;
2793 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
2794 PL_main_root->op_private |= OPpREFCOUNTED;
2795 OpREFCNT_set(PL_main_root, 1);
3280af22 2796 PL_main_root->op_next = 0;
a2efc822 2797 CALL_PEEP(PL_main_start);
d164302a 2798 finalize_optree(PL_main_root);
3280af22 2799 PL_compcv = 0;
3841441e 2800
4fdae800 2801 /* Register with debugger */
84902520 2802 if (PERLDB_INTER) {
b96d8cd9 2803 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS
2804 if (cv) {
2805 dSP;
924508f0 2806 PUSHMARK(SP);
ad64d0ec 2807 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 2808 PUTBACK;
ad64d0ec 2809 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS
2810 }
2811 }
79072805 2812 }
79072805
LW
2813}
2814
2815OP *
864dbfa3 2816Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2817{
97aff369 2818 dVAR;
7918f24d
NC
2819
2820 PERL_ARGS_ASSERT_LOCALIZE;
2821
79072805 2822 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
2823/* [perl #17376]: this appears to be premature, and results in code such as
2824 C< our(%x); > executing in list mode rather than void mode */
2825#if 0
79072805 2826 list(o);
d2be0de5 2827#else
6f207bd3 2828 NOOP;
d2be0de5 2829#endif
8990e307 2830 else {
f06b5848
DM
2831 if ( PL_parser->bufptr > PL_parser->oldbufptr
2832 && PL_parser->bufptr[-1] == ','
041457d9 2833 && ckWARN(WARN_PARENTHESIS))
64420d0d 2834 {
f06b5848 2835 char *s = PL_parser->bufptr;
bac662ee 2836 bool sigil = FALSE;
64420d0d 2837
8473848f 2838 /* some heuristics to detect a potential error */
bac662ee 2839 while (*s && (strchr(", \t\n", *s)))
64420d0d 2840 s++;
8473848f 2841
bac662ee
ST
2842 while (1) {
2843 if (*s && strchr("@$%*", *s) && *++s
2844 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2845 s++;
2846 sigil = TRUE;
2847 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2848 s++;
2849 while (*s && (strchr(", \t\n", *s)))
2850 s++;
2851 }
2852 else
2853 break;
2854 }
2855 if (sigil && (*s == ';' || *s == '=')) {
2856 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2857 "Parentheses missing around \"%s\" list",
12bd6ede
DM
2858 lex
2859 ? (PL_parser->in_my == KEY_our
2860 ? "our"
2861 : PL_parser->in_my == KEY_state
2862 ? "state"
2863 : "my")
2864 : "local");
8473848f 2865 }
8990e307
LW
2866 }
2867 }
93a17b20 2868 if (lex)
eb64745e 2869 o = my(o);
93a17b20 2870 else
3ad73efd 2871 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM
2872 PL_parser->in_my = FALSE;
2873 PL_parser->in_my_stash = NULL;
eb64745e 2874 return o;
79072805
LW
2875}
2876
2877OP *
864dbfa3 2878Perl_jmaybe(pTHX_ OP *o)
79072805 2879{
7918f24d
NC
2880 PERL_ARGS_ASSERT_JMAYBE;
2881
79072805 2882 if (o->op_type == OP_LIST) {
fafc274c 2883 OP * const o2
d4c19fe8 2884 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 2885 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW
2886 }
2887 return o;
2888}
2889
1f676739 2890static OP *
b7783a12 2891S_fold_constants(pTHX_ register OP *o)
79072805 2892{
27da23d5 2893 dVAR;
001d637e 2894 register OP * VOL curop;
eb8433b7 2895 OP *newop;
8ea43dc8 2896 VOL I32 type = o->op_type;
e3cbe32f 2897 SV * VOL sv = NULL;
b7f7fd0b
NC
2898 int ret = 0;
2899 I32 oldscope;
2900 OP *old_next;
5f2d9966
DM
2901 SV * const oldwarnhook = PL_warnhook;
2902 SV * const olddiehook = PL_diehook;
c427f4d2 2903 COP not_compiling;
b7f7fd0b 2904 dJMPENV;
79072805 2905
7918f24d
NC
2906 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2907
22c35a8c 2908 if (PL_opargs[type] & OA_RETSCALAR)
79072805 2909 scalar(o);
b162f9ea 2910 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
ed6116ce 2911 o->op_targ = pad_alloc(type, SVs_PADTMP);
79072805 2912
eac055e9
GS
2913 /* integerize op, unless it happens to be C<-foo>.
2914 * XXX should pp_i_negate() do magic string negation instead? */
2915 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2916 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2917 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2918 {
22c35a8c 2919 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
eac055e9 2920 }
85e6fe83 2921
22c35a8c 2922 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
2923 goto nope;
2924
de939608 2925 switch (type) {
7a52d87a
GS
2926 case OP_NEGATE:
2927 /* XXX might want a ck_negate() for this */
2928 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2929 break;
de939608
CS
2930 case OP_UCFIRST:
2931 case OP_LCFIRST:
2932 case OP_UC:
2933 case OP_LC:
69dcf70c
MB
2934 case OP_SLT:
2935 case OP_SGT:
2936 case OP_SLE:
2937 case OP_SGE:
2938 case OP_SCMP:
b3fd6149 2939 case OP_SPRINTF:
2de3dbcc
JH
2940 /* XXX what about the numeric ops? */
2941 if (PL_hints & HINT_LOCALE)
de939608 2942 goto nope;
553e7bb0 2943 break;
de939608
CS
2944 }
2945
13765c85 2946 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
2947 goto nope; /* Don't try to run w/ errors */
2948
79072805 2949 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL
2950 const OPCODE type = curop->op_type;
2951 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2952 type != OP_LIST &&
2953 type != OP_SCALAR &&
2954 type != OP_NULL &&
2955 type != OP_PUSHMARK)
7a52d87a 2956 {
79072805
LW
2957 goto nope;
2958 }
2959 }
2960
2961 curop = LINKLIST(o);
b7f7fd0b 2962 old_next = o->op_next;
79072805 2963 o->op_next = 0;
533c011a 2964 PL_op = curop;
b7f7fd0b
NC
2965
2966 oldscope = PL_scopestack_ix;
edb2152a 2967 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 2968
c427f4d2
NC
2969 /* Verify that we don't need to save it: */
2970 assert(PL_curcop == &PL_compiling);
2971 StructCopy(&PL_compiling, &not_compiling, COP);
2972 PL_curcop = &not_compiling;
2973 /* The above ensures that we run with all the correct hints of the
2974 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2975 assert(IN_PERL_RUNTIME);
5f2d9966
DM
2976 PL_warnhook = PERL_WARNHOOK_FATAL;
2977 PL_diehook = NULL;
b7f7fd0b
NC
2978 JMPENV_PUSH(ret);
2979
2980 switch (ret) {
2981 case 0:
2982 CALLRUNOPS(aTHX);
2983 sv = *(PL_stack_sp--);
523a0f0c
NC
2984 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
2985#ifdef PERL_MAD
2986 /* Can't simply swipe the SV from the pad, because that relies on
2987 the op being freed "real soon now". Under MAD, this doesn't
2988 happen (see the #ifdef below). */
2989 sv = newSVsv(sv);
2990#else
b7f7fd0b 2991 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC
2992#endif
2993 }
b7f7fd0b
NC
2994 else if (SvTEMP(sv)) { /* grab mortal temp? */
2995 SvREFCNT_inc_simple_void(sv);
2996 SvTEMP_off(sv);
2997 }
2998 break;
2999 case 3:
3000 /* Something tried to die. Abandon constant folding. */
3001 /* Pretend the error never happened. */
ab69dbc2 3002 CLEAR_ERRSV();
b7f7fd0b
NC
3003 o->op_next = old_next;
3004 break;
3005 default:
3006 JMPENV_POP;
5f2d9966
DM
3007 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3008 PL_warnhook = oldwarnhook;
3009 PL_diehook = olddiehook;
3010 /* XXX note that this croak may fail as we've already blown away
3011 * the stack - eg any nested evals */
b7f7fd0b
NC
3012 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3013 }
b7f7fd0b 3014 JMPENV_POP;
5f2d9966
DM
3015 PL_warnhook = oldwarnhook;
3016 PL_diehook = olddiehook;
c427f4d2 3017 PL_curcop = &PL_compiling;
edb2152a
NC
3018
3019 if (PL_scopestack_ix > oldscope)
3020 delete_eval_scope();
eb8433b7 3021
b7f7fd0b
NC
3022 if (ret)
3023 goto nope;
3024
eb8433b7 3025#ifndef PERL_MAD
79072805 3026 op_free(o);
eb8433b7 3027#endif
de5e01c2 3028 assert(sv);
79072805 3029 if (type == OP_RV2GV)
159b6efe 3030 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3031 else
ad64d0ec 3032 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
eb8433b7
NC
3033 op_getmad(o,newop,'f');
3034 return newop;
aeea060c 3035
b7f7fd0b 3036 nope:
79072805
LW
3037 return o;
3038}
3039
1f676739 3040static OP *
b7783a12 3041S_gen_constant_list(pTHX_ register OP *o)
79072805 3042{
27da23d5 3043 dVAR;
79072805 3044 register OP *curop;
6867be6d 3045 const I32 oldtmps_floor = PL_tmps_floor;
79072805 3046
a0d0e21e 3047 list(o);
13765c85 3048 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
3049 return o; /* Don't attempt to run with errors */
3050
533c011a 3051 PL_op = curop = LINKLIST(o);
a0d0e21e 3052 o->op_next = 0;
a2efc822 3053 CALL_PEEP(curop);
897d3989 3054 Perl_pp_pushmark(aTHX);
cea2e8a9 3055 CALLRUNOPS(aTHX);
533c011a 3056 PL_op = curop;
78c72037
NC
3057 assert (!(curop->op_flags & OPf_SPECIAL));
3058 assert(curop->op_type == OP_RANGE);
897d3989 3059 Perl_pp_anonlist(aTHX);
3280af22 3060 PL_tmps_floor = oldtmps_floor;
79072805
LW
3061
3062 o->op_type = OP_RV2AV;
22c35a8c 3063 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG
3064 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3065 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3066 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3067 curop = ((UNOP*)o)->op_first;
b37c2d43 3068 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC
3069#ifdef PERL_MAD
3070 op_getmad(curop,o,'O');
3071#else
79072805 3072 op_free(curop);
eb8433b7 3073#endif
5983a79d 3074 LINKLIST(o);
79072805
LW
3075 return list(o);
3076}
3077
3078OP *
864dbfa3 3079Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3080{
27da23d5 3081 dVAR;
11343788 3082 if (!o || o->op_type != OP_LIST)
5f66b61c 3083 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3084 else
5dc0d613 3085 o->op_flags &= ~OPf_WANT;
79072805 3086
22c35a8c 3087 if (!(PL_opargs[type] & OA_MARK))
93c66552 3088 op_null(cLISTOPo->op_first);
8990e307 3089
eb160463 3090 o->op_type = (OPCODE)type;
22c35a8c 3091 o->op_ppaddr = PL_ppaddr[type];
11343788 3092 o->op_flags |= flags;
79072805 3093
11343788 3094 o = CHECKOP(type, o);
fe2774ed 3095 if (o->op_type != (unsigned)type)
11343788 3096 return o;
79072805 3097
11343788 3098 return fold_constants(o);
79072805
LW
3099}
3100
2fcb4757
Z
3101/*
3102=head1 Optree Manipulation Functions
3103*/
3104
79072805
LW
3105/* List constructors */
3106
2fcb4757
Z
3107/*
3108=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3109
3110Append an item to the list of ops contained directly within a list-type
3111op, returning the lengthened list. I<first> is the list-type op,
3112and I<last> is the op to append to the list. I<optype> specifies the
3113intended opcode for the list. If I<first> is not already a list of the
3114right type, it will be upgraded into one. If either I<first> or I<last>
3115is null, the other is returned unchanged.
3116
3117=cut
3118*/
3119
79072805 3120OP *
2fcb4757 3121Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3122{
3123 if (!first)
3124 return last;
8990e307
LW
3125
3126 if (!last)
79072805 3127 return first;
8990e307 3128
fe2774ed 3129 if (first->op_type != (unsigned)type
155aba94
GS
3130 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3131 {
3132 return newLISTOP(type, 0, first, last);
3133 }
79072805 3134
a0d0e21e
LW
3135 if (first->op_flags & OPf_KIDS)
3136 ((LISTOP*)first)->op_last->op_sibling = last;
3137 else {
3138 first->op_flags |= OPf_KIDS;
3139 ((LISTOP*)first)->op_first = last;
3140 }
3141 ((LISTOP*)first)->op_last = last;
a0d0e21e 3142 return first;
79072805
LW
3143}
3144
2fcb4757
Z
3145/*
3146=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3147
3148Concatenate the lists of ops contained directly within two list-type ops,
3149returning the combined list. I<first> and I<last> are the list-type ops
3150to concatenate. I<optype> specifies the intended opcode for the list.
3151If either I<first> or I<last> is not already a list of the right type,
3152it will be upgraded into one. If either I<first> or I<last> is null,
3153the other is returned unchanged.
3154
3155=cut
3156*/
3157
79072805 3158OP *
2fcb4757 3159Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3160{
3161 if (!first)
2fcb4757 3162 return last;
8990e307
LW
3163
3164 if (!last)
2fcb4757 3165 return first;
8990e307 3166
fe2774ed 3167 if (first->op_type != (unsigned)type)
2fcb4757 3168 return op_prepend_elem(type, first, last);
8990e307 3169
fe2774ed 3170 if (last->op_type != (unsigned)type)
2fcb4757 3171 return op_append_elem(type, first, last);
79072805 3172
2fcb4757
Z
3173 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3174 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3175 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3176
eb8433b7 3177#ifdef PERL_MAD
2fcb4757
Z
3178 if (((LISTOP*)last)->op_first && first->op_madprop) {
3179 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC
3180 if (mp) {
3181 while (mp->mad_next)
3182 mp = mp->mad_next;
3183 mp->mad_next = first->op_madprop;
3184 }
3185 else {
2fcb4757 3186 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC
3187 }
3188 }
3189 first->op_madprop = last->op_madprop;
3190 last->op_madprop = 0;
3191#endif
3192
2fcb4757 3193 S_op_destroy(aTHX_ last);
238a4c30 3194
2fcb4757 3195 return first;
79072805
LW
3196}
3197
2fcb4757
Z
3198/*
3199=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3200
3201Prepend an item to the list of ops contained directly within a list-type
3202op, returning the lengthened list. I<first> is the op to prepend to the
3203list, and I<last> is the list-type op. I<optype> specifies the intended
3204opcode for the list. If I<last> is not already a list of the right type,
3205it will be upgraded into one. If either I<first> or I<last> is null,
3206the other is returned unchanged.
3207
3208=cut
3209*/
3210
79072805 3211OP *
2fcb4757 3212Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3213{
3214 if (!first)
3215 return last;
8990e307
LW
3216
3217 if (!last)
79072805 3218 return first;
8990e307 3219
fe2774ed 3220 if (last->op_type == (unsigned)type) {
8990e307
LW
3221 if (type == OP_LIST) { /* already a PUSHMARK there */
3222 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3223 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
3224 if (!(first->op_flags & OPf_PARENS))
3225 last->op_flags &= ~OPf_PARENS;
8990e307
LW
3226 }
3227 else {
3228 if (!(last->op_flags & OPf_KIDS)) {
3229 ((LISTOP*)last)->op_last = first;
3230 last->op_flags |= OPf_KIDS;
3231 }
3232 first->op_sibling = ((LISTOP*)last)->op_first;
3233 ((LISTOP*)last)->op_first = first;
79072805 3234 }
117dada2 3235 last->op_flags |= OPf_KIDS;
79072805
LW
3236 return last;
3237 }
3238
3239 return newLISTOP(type, 0, first, last);
3240}
3241
3242/* Constructors */
3243
eb8433b7
NC
3244#ifdef PERL_MAD
3245
3246TOKEN *
3247Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3248{
3249 TOKEN *tk;
99129197 3250 Newxz(tk, 1, TOKEN);
eb8433b7
NC
3251 tk->tk_type = (OPCODE)optype;
3252 tk->tk_type = 12345;
3253 tk->tk_lval = lval;
3254 tk->tk_mad = madprop;
3255 return tk;
3256}
3257
3258void
3259Perl_token_free(pTHX_ TOKEN* tk)
3260{
7918f24d
NC
3261 PERL_ARGS_ASSERT_TOKEN_FREE;
3262
eb8433b7
NC
3263 if (tk->tk_type != 12345)
3264 return;
3265 mad_free(tk->tk_mad);
3266 Safefree(tk);
3267}
3268
3269void
3270Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3271{
3272 MADPROP* mp;
3273 MADPROP* tm;
7918f24d
NC
3274
3275 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3276
eb8433b7
NC
3277 if (tk->tk_type != 12345) {
3278 Perl_warner(aTHX_ packWARN(WARN_MISC),
3279 "Invalid TOKEN object ignored");
3280 return;
3281 }
3282 tm = tk->tk_mad;
3283 if (!tm)
3284 return;
3285
3286 /* faked up qw list? */
3287 if (slot == '(' &&
3288 tm->mad_type == MAD_SV &&
d503a9ba 3289 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC
3290 slot = 'x';
3291
3292 if (o) {
3293 mp = o->op_madprop;
3294 if (mp) {
3295 for (;;) {
3296 /* pretend constant fold didn't happen? */
3297 if (mp->mad_key == 'f' &&
3298 (o->op_type == OP_CONST ||
3299 o->op_type == OP_GV) )
3300 {
3301 token_getmad(tk,(OP*)mp->mad_val,slot);
3302 return;
3303 }
3304 if (!mp->mad_next)
3305 break;
3306 mp = mp->mad_next;
3307 }
3308 mp->mad_next = tm;
3309 mp = mp->mad_next;
3310 }
3311 else {
3312 o->op_madprop = tm;
3313 mp = o->op_madprop;
3314 }
3315 if (mp->mad_key == 'X')
3316 mp->mad_key = slot; /* just change the first one */
3317
3318 tk->tk_mad = 0;
3319 }
3320 else
3321 mad_free(tm);
3322 Safefree(tk);
3323}
3324
3325void
3326Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3327{
3328 MADPROP* mp;
3329 if (!from)
3330 return;
3331 if (o) {
3332 mp = o->op_madprop;
3333 if (mp) {
3334 for (;;) {
3335 /* pretend constant fold didn't happen? */
3336 if (mp->mad_key == 'f' &&
3337 (o->op_type == OP_CONST ||
3338 o->op_type == OP_GV) )
3339 {
3340 op_getmad(from,(OP*)mp->mad_val,slot);
3341 return;
3342 }
3343 if (!mp->mad_next)
3344 break;
3345 mp = mp->mad_next;
3346 }
3347 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3348 }
3349 else {
3350 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3351 }
3352 }
3353}
3354
3355void
3356Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3357{
3358 MADPROP* mp;
3359 if (!from)
3360 return;
3361 if (o) {
3362 mp = o->op_madprop;
3363 if (mp) {
3364 for (;;) {
3365 /* pretend constant fold didn't happen? */
3366 if (mp->mad_key == 'f' &&
3367 (o->op_type == OP_CONST ||
3368 o->op_type == OP_GV) )
3369 {
3370 op_getmad(from,(OP*)mp->mad_val,slot);
3371 return;
3372 }
3373 if (!mp->mad_next)
3374 break;
3375 mp = mp->mad_next;
3376 }
3377 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3378 }
3379 else {
3380 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3381 }
3382 }
3383 else {
99129197
NC
3384 PerlIO_printf(PerlIO_stderr(),
3385 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC
3386 op_free(from);
3387 }
3388}
3389
3390void
3391Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3392{
3393 MADPROP* tm;
3394 if (!mp || !o)
3395 return;
3396 if (slot)
3397 mp->mad_key = slot;
3398 tm = o->op_madprop;
3399 o->op_madprop = mp;
3400 for (;;) {
3401 if (!mp->mad_next)
3402 break;
3403 mp = mp->mad_next;
3404 }
3405 mp->mad_next = tm;
3406}
3407
3408void
3409Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3410{
3411 if (!o)
3412 return;
3413 addmad(tm, &(o->op_madprop), slot);
3414}
3415
3416void
3417Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3418{
3419 MADPROP* mp;
3420 if (!tm || !root)
3421 return;
3422 if (slot)
3423 tm->mad_key = slot;
3424 mp = *root;
3425 if (!mp) {
3426 *root = tm;
3427 return;
3428 }
3429 for (;;) {
3430 if (!mp->mad_next)
3431 break;
3432 mp = mp->mad_next;
3433 }
3434 mp->mad_next = tm;
3435}
3436
3437MADPROP *
3438Perl_newMADsv(pTHX_ char key, SV* sv)
3439{
7918f24d
NC
3440 PERL_ARGS_ASSERT_NEWMADSV;
3441
eb8433b7
NC
3442 return newMADPROP(key, MAD_SV, sv, 0);
3443}
3444
3445MADPROP *
d503a9ba 3446Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 3447{
c111d5f1 3448 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC
3449 mp->mad_next = 0;
3450 mp->mad_key = key;
3451 mp->mad_vlen = vlen;
3452 mp->mad_type = type;
3453 mp->mad_val = val;
3454/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3455 return mp;
3456}
3457
3458void
3459Perl_mad_free(pTHX_ MADPROP* mp)
3460{
3461/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3462 if (!mp)
3463 return;
3464 if (mp->mad_next)
3465 mad_free(mp->mad_next);
bc177e6b 3466/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC
3467 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3468 switch (mp->mad_type) {
3469 case MAD_NULL:
3470 break;
3471 case MAD_PV:
3472 Safefree((char*)mp->mad_val);
3473 break;
3474 case MAD_OP:
3475 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3476 op_free((OP*)mp->mad_val);
3477 break;
3478 case MAD_SV:
ad64d0ec 3479 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC
3480 break;
3481 default:
3482 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3483 break;
3484 }
c111d5f1 3485 PerlMemShared_free(mp);
eb8433b7
NC
3486}
3487
3488#endif
3489
d67eb5f4
Z
3490/*
3491=head1 Optree construction
3492
3493=for apidoc Am|OP *|newNULLLIST
3494
3495Constructs, checks, and returns a new C<stub> op, which represents an
3496empty list expression.
3497
3498=cut
3499*/
3500
79072805 3501OP *
864dbfa3 3502Perl_newNULLLIST(pTHX)
79072805 3503{
8990e307
LW
3504 return newOP(OP_STUB, 0);
3505}
3506
1f676739 3507static OP *
b7783a12 3508S_force_list(pTHX_ OP *o)
8990e307 3509{
11343788 3510 if (!o || o->op_type != OP_LIST)
5f66b61c 3511 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3512 op_null(o);
11343788 3513 return o;
79072805
LW
3514}
3515
d67eb5f4
Z
3516/*
3517=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3518
3519Constructs, checks, and returns an op of any list type. I<type> is
3520the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3521C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3522supply up to two ops to be direct children of the list op; they are
3523consumed by this function and become part of the constructed op tree.
3524
3525=cut
3526*/
3527
79072805 3528OP *
864dbfa3 3529Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3530{
27da23d5 3531 dVAR;
79072805
LW
3532 LISTOP *listop;
3533
e69777c1
GG
3534 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3535
b7dc083c 3536 NewOp(1101, listop, 1, LISTOP);
79072805 3537
eb160463 3538 listop->op_type = (OPCODE)type;
22c35a8c 3539 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM
3540 if (first || last)
3541 flags |= OPf_KIDS;
eb160463 3542 listop->op_flags = (U8)flags;
79072805
LW
3543
3544 if (!last && first)
3545 last = first;
3546 else if (!first && last)
3547 first = last;
8990e307
LW
3548 else if (first)
3549 first->op_sibling = last;
79072805
LW
3550 listop->op_first = first;
3551 listop->op_last = last;
8990e307 3552 if (type == OP_LIST) {
551405c4 3553 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW
3554 pushop->op_sibling = first;
3555 listop->op_first = pushop;
3556 listop->op_flags |= OPf_KIDS;
3557 if (!last)
3558 listop->op_last = pushop;
3559 }
79072805 3560
463d09e6 3561 return CHECKOP(type, listop);
79072805
LW
3562}
3563
d67eb5f4
Z
3564/*
3565=for apidoc Am|OP *|newOP|I32 type|I32 flags
3566
3567Constructs, checks, and returns an op of any base type (any type that
3568has no extra fields). I<type> is the opcode. I<flags> gives the
3569eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3570of C<op_private>.
3571
3572=cut
3573*/
3574
79072805 3575OP *
864dbfa3 3576Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3577{
27da23d5 3578 dVAR;
11343788 3579 OP *o;
e69777c1
GG
3580
3581 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3582 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3583 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3584 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3585
b7dc083c 3586 NewOp(1101, o, 1, OP);
eb160463 3587 o->op_type = (OPCODE)type;
22c35a8c 3588 o->op_ppaddr = PL_ppaddr[type];
eb160463 3589 o->op_flags = (U8)flags;
670f3923
DM
3590 o->op_latefree = 0;
3591 o->op_latefreed = 0;
7e5d8ed2 3592 o->op_attached = 0;
79072805 3593
11343788 3594 o->op_next = o;
eb160463 3595 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3596 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3597 scalar(o);
22c35a8c 3598 if (PL_opargs[type] & OA_TARGET)
11343788
MB
3599 o->op_targ = pad_alloc(type, SVs_PADTMP);
3600 return CHECKOP(type, o);
79072805
LW
3601}
3602
d67eb5f4
Z
3603/*
3604=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3605
3606Constructs, checks, and returns an op of any unary type. I<type> is
3607the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3608C<OPf_KIDS> will be set automatically if required, and, shifted up eight
3609bits, the eight bits of C<op_private>, except that the bit with value 1
3610is automatically set. I<first> supplies an optional op to be the direct
3611child of the unary op; it is consumed by this function and become part
3612of the constructed op tree.
3613
3614=cut
3615*/
3616
79072805 3617OP *
864dbfa3 3618Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
79072805 3619{
27da23d5 3620 dVAR;
79072805
LW
3621 UNOP *unop;
3622
e69777c1
GG
3623 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
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 || type == OP_SASSIGN
32e2a35d 3628 || type == OP_ENTERTRY
e69777c1
GG
3629 || type == OP_NULL );
3630
93a17b20 3631 if (!first)
aeea060c 3632 first = newOP(OP_STUB, 0);
22c35a8c 3633 if (PL_opargs[type] & OA_MARK)
8990e307 3634 first = force_list(first);
93a17b20 3635
b7dc083c 3636 NewOp(1101, unop, 1, UNOP);
eb160463 3637 unop->op_type = (OPCODE)type;
22c35a8c 3638 unop->op_ppaddr = PL_ppaddr[type];
79072805 3639 unop->op_first = first;
585ec06d 3640 unop->op_flags = (U8)(flags | OPf_KIDS);
eb160463 3641 unop->op_private = (U8)(1 | (flags >> 8));
e50aee73 3642 unop = (UNOP*) CHECKOP(type, unop);
79072805
LW
3643 if (unop->op_next)
3644 return (OP*)unop;
3645
a0d0e21e 3646 return fold_constants((OP *) unop);
79072805
LW
3647}
3648
d67eb5f4
Z
3649/*