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