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