This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Increase $B::VERSION to 1.36
[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 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 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 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() */
1efec5ed
FC		 2025
2026 case OP_COREARGS:
2027 return o;
463ee0b2 2028 }
58d95175 2029
8be1be90
AMS		 2030 /* [20011101.069] File test operators interpret OPf_REF to mean that
2031 their argument is a filehandle; thus \stat(".") should not set
2032 it. AMS 20011102 */
2033 if (type == OP_REFGEN &&
ef69c8fc 2034 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS		 2035 return o;
2036
2037 if (type != OP_LEAVESUBLV)
2038 o->op_flags |= OPf_MOD;
2039
2040 if (type == OP_AASSIGN || type == OP_SASSIGN)
2041 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 2042 else if (!type) { /* local() */
2043 switch (localize) {
2044 case 1:
2045 o->op_private |= OPpLVAL_INTRO;
2046 o->op_flags &= ~OPf_SPECIAL;
2047 PL_hints |= HINT_BLOCK_SCOPE;
2048 break;
2049 case 0:
2050 break;
2051 case -1:
a2a5de95
NC		 2052 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2053 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2054 }
463ee0b2 2055 }
8be1be90
AMS		 2056 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2057 && type != OP_LEAVESUBLV)
2058 o->op_flags |= OPf_REF;
11343788 2059 return o;
463ee0b2
LW		 2060}
2061
864dbfa3 2062STATIC bool
5f66b61c 2063S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2064{
2065 switch (type) {
32a60974 2066 case OP_POS:
3fe9a6f1 2067 case OP_SASSIGN:
1efec5ed 2068 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 2069 return FALSE;
2070 /* FALL THROUGH */
2071 case OP_PREINC:
2072 case OP_PREDEC:
2073 case OP_POSTINC:
2074 case OP_POSTDEC:
2075 case OP_I_PREINC:
2076 case OP_I_PREDEC:
2077 case OP_I_POSTINC:
2078 case OP_I_POSTDEC:
2079 case OP_POW:
2080 case OP_MULTIPLY:
2081 case OP_DIVIDE:
2082 case OP_MODULO:
2083 case OP_REPEAT:
2084 case OP_ADD:
2085 case OP_SUBTRACT:
2086 case OP_I_MULTIPLY:
2087 case OP_I_DIVIDE:
2088 case OP_I_MODULO:
2089 case OP_I_ADD:
2090 case OP_I_SUBTRACT:
2091 case OP_LEFT_SHIFT:
2092 case OP_RIGHT_SHIFT:
2093 case OP_BIT_AND:
2094 case OP_BIT_XOR:
2095 case OP_BIT_OR:
2096 case OP_CONCAT:
2097 case OP_SUBST:
2098 case OP_TRANS:
bb16bae8 2099 case OP_TRANSR:
49e9fbe6
GS		 2100 case OP_READ:
2101 case OP_SYSREAD:
2102 case OP_RECV:
bf4b1e52
GS		 2103 case OP_ANDASSIGN:
2104 case OP_ORASSIGN:
410d09fe 2105 case OP_DORASSIGN:
3fe9a6f1 2106 return TRUE;
2107 default:
2108 return FALSE;
2109 }
2110}
2111
35cd451c 2112STATIC bool
5f66b61c 2113S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2114{
7918f24d
NC		 2115 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2116
35cd451c
GS		 2117 switch (o->op_type) {
2118 case OP_PIPE_OP:
2119 case OP_SOCKPAIR:
504618e9 2120 if (numargs == 2)
35cd451c
GS		 2121 return TRUE;
2122 /* FALL THROUGH */
2123 case OP_SYSOPEN:
2124 case OP_OPEN:
ded8aa31 2125 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 2126 case OP_SOCKET:
2127 case OP_OPEN_DIR:
2128 case OP_ACCEPT:
504618e9 2129 if (numargs == 1)
35cd451c 2130 return TRUE;
5f66b61c 2131 /* FALLTHROUGH */
35cd451c
GS		 2132 default:
2133 return FALSE;
2134 }
2135}
2136
0d86688d
NC		 2137static OP *
2138S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2139{
11343788 2140 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2141 OP *kid;
11343788 2142 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 2143 ref(kid, type);
2144 }
11343788 2145 return o;
463ee0b2
LW		 2146}
2147
2148OP *
e4c5ccf3 2149Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2150{
27da23d5 2151 dVAR;
463ee0b2 2152 OP *kid;
463ee0b2 2153
7918f24d
NC		 2154 PERL_ARGS_ASSERT_DOREF;
2155
13765c85 2156 if (!o || (PL_parser && PL_parser->error_count))
11343788 2157 return o;
463ee0b2 2158
11343788 2159 switch (o->op_type) {
a0d0e21e 2160 case OP_ENTERSUB:
f4df43b5 2161 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB		 2162 !(o->op_flags & OPf_STACKED)) {
2163 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2164 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2165 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2166 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2167 o->op_flags |= OPf_SPECIAL;
e26df76a 2168 o->op_private &= ~1;
8990e307 2169 }
767eda44 2170 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG		 2171 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2172 : type == OP_RV2HV ? OPpDEREF_HV
2173 : OPpDEREF_SV);
767eda44
FC		 2174 o->op_flags |= OPf_MOD;
2175 }
2176
8990e307 2177 break;
aeea060c 2178
463ee0b2 2179 case OP_COND_EXPR:
11343788 2180 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2181 doref(kid, type, set_op_ref);
463ee0b2 2182 break;
8990e307 2183 case OP_RV2SV:
35cd451c
GS		 2184 if (type == OP_DEFINED)
2185 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2186 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 2187 /* FALL THROUGH */
2188 case OP_PADSV:
5f05dabc 2189 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2190 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2191 : type == OP_RV2HV ? OPpDEREF_HV
2192 : OPpDEREF_SV);
11343788 2193 o->op_flags |= OPf_MOD;
a0d0e21e 2194 }
8990e307 2195 break;
1c846c1f 2196
463ee0b2
LW		 2197 case OP_RV2AV:
2198 case OP_RV2HV:
e4c5ccf3
RH		 2199 if (set_op_ref)
2200 o->op_flags |= OPf_REF;
8990e307 2201 /* FALL THROUGH */
463ee0b2 2202 case OP_RV2GV:
35cd451c
GS		 2203 if (type == OP_DEFINED)
2204 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2205 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2206 break;
8990e307 2207
463ee0b2
LW		 2208 case OP_PADAV:
2209 case OP_PADHV:
e4c5ccf3
RH		 2210 if (set_op_ref)
2211 o->op_flags |= OPf_REF;
79072805 2212 break;
aeea060c 2213
8990e307 2214 case OP_SCALAR:
79072805 2215 case OP_NULL:
11343788 2216 if (!(o->op_flags & OPf_KIDS))
463ee0b2 2217 break;
e4c5ccf3 2218 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 2219 break;
2220 case OP_AELEM:
2221 case OP_HELEM:
e4c5ccf3 2222 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2223 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2224 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2225 : type == OP_RV2HV ? OPpDEREF_HV
2226 : OPpDEREF_SV);
11343788 2227 o->op_flags |= OPf_MOD;
8990e307 2228 }
79072805
LW		 2229 break;
2230
463ee0b2 2231 case OP_SCOPE:
79072805 2232 case OP_LEAVE:
e4c5ccf3
RH		 2233 set_op_ref = FALSE;
2234 /* FALL THROUGH */
79072805 2235 case OP_ENTER:
8990e307 2236 case OP_LIST:
11343788 2237 if (!(o->op_flags & OPf_KIDS))
79072805 2238 break;
e4c5ccf3 2239 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2240 break;
a0d0e21e
LW		 2241 default:
2242 break;
79072805 2243 }
11343788 2244 return scalar(o);
8990e307 2245
79072805
LW		 2246}
2247
09bef843
SB		 2248STATIC OP *
2249S_dup_attrlist(pTHX_ OP *o)
2250{
97aff369 2251 dVAR;
0bd48802 2252 OP *rop;
09bef843 2253
7918f24d
NC		 2254 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2255
09bef843
SB		 2256 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2257 * where the first kid is OP_PUSHMARK and the remaining ones
2258 * are OP_CONST. We need to push the OP_CONST values.
2259 */
2260 if (o->op_type == OP_CONST)
b37c2d43 2261 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 2262#ifdef PERL_MAD
2263 else if (o->op_type == OP_NULL)
1d866c12 2264 rop = NULL;
eb8433b7 2265#endif
09bef843
SB		 2266 else {
2267 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2268 rop = NULL;
09bef843
SB		 2269 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2270 if (o->op_type == OP_CONST)
2fcb4757 2271 rop = op_append_elem(OP_LIST, rop,
09bef843 2272 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2273 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 2274 }
2275 }
2276 return rop;
2277}
2278
2279STATIC void
95f0a2f1 2280S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
09bef843 2281{
27da23d5 2282 dVAR;
09bef843
SB		 2283 SV *stashsv;
2284
7918f24d
NC		 2285 PERL_ARGS_ASSERT_APPLY_ATTRS;
2286
09bef843
SB		 2287 /* fake up C<use attributes $pkg,$rv,@attrs> */
2288 ENTER; /* need to protect against side-effects of 'use' */
5aaec2b4 2289 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
e4783991 2290
09bef843 2291#define ATTRSMODULE "attributes"
95f0a2f1
SB		 2292#define ATTRSMODULE_PM "attributes.pm"
2293
2294 if (for_my) {
95f0a2f1 2295 /* Don't force the C<use> if we don't need it. */
a4fc7abc 2296 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
95f0a2f1 2297 if (svp && *svp != &PL_sv_undef)
6f207bd3 2298 NOOP; /* already in %INC */
95f0a2f1
SB		 2299 else
2300 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6136c704 2301 newSVpvs(ATTRSMODULE), NULL);
95f0a2f1
SB		 2302 }
2303 else {
2304 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 2305 newSVpvs(ATTRSMODULE),
2306 NULL,
2fcb4757 2307 op_prepend_elem(OP_LIST,
95f0a2f1 2308 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2309 op_prepend_elem(OP_LIST,
95f0a2f1
SB		 2310 newSVOP(OP_CONST, 0,
2311 newRV(target)),
2312 dup_attrlist(attrs))));
2313 }
09bef843
SB		 2314 LEAVE;
2315}
2316
95f0a2f1
SB		 2317STATIC void
2318S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2319{
97aff369 2320 dVAR;
95f0a2f1
SB		 2321 OP *pack, *imop, *arg;
2322 SV *meth, *stashsv;
2323
7918f24d
NC		 2324 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2325
95f0a2f1
SB		 2326 if (!attrs)
2327 return;
2328
2329 assert(target->op_type == OP_PADSV ||
2330 target->op_type == OP_PADHV ||
2331 target->op_type == OP_PADAV);
2332
2333 /* Ensure that attributes.pm is loaded. */
dd2155a4 2334 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
95f0a2f1
SB		 2335
2336 /* Need package name for method call. */
6136c704 2337 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 2338
2339 /* Build up the real arg-list. */
5aaec2b4
NC		 2340 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2341
95f0a2f1
SB		 2342 arg = newOP(OP_PADSV, 0);
2343 arg->op_targ = target->op_targ;
2fcb4757 2344 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2345 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2346 op_prepend_elem(OP_LIST,
95f0a2f1 2347 newUNOP(OP_REFGEN, 0,
3ad73efd 2348 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB		 2349 dup_attrlist(attrs)));
2350
2351 /* Fake up a method call to import */
18916d0d 2352 meth = newSVpvs_share("import");
95f0a2f1 2353 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z		 2354 op_append_elem(OP_LIST,
2355 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2356 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB		 2357
2358 /* Combine the ops. */
2fcb4757 2359 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB		 2360}
2361
2362/*
2363=notfor apidoc apply_attrs_string
2364
2365Attempts to apply a list of attributes specified by the C<attrstr> and
2366C<len> arguments to the subroutine identified by the C<cv> argument which
2367is expected to be associated with the package identified by the C<stashpv>
2368argument (see L<attributes>). It gets this wrong, though, in that it
2369does not correctly identify the boundaries of the individual attribute
2370specifications within C<attrstr>. This is not really intended for the
2371public API, but has to be listed here for systems such as AIX which
2372need an explicit export list for symbols. (It's called from XS code
2373in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2374to respect attribute syntax properly would be welcome.
2375
2376=cut
2377*/
2378
be3174d2 2379void
6867be6d
AL		 2380Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2381 const char *attrstr, STRLEN len)
be3174d2 2382{
5f66b61c 2383 OP *attrs = NULL;
be3174d2 2384
7918f24d
NC		 2385 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2386
be3174d2
GS		 2387 if (!len) {
2388 len = strlen(attrstr);
2389 }
2390
2391 while (len) {
2392 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2393 if (len) {
890ce7af 2394 const char * const sstr = attrstr;
be3174d2 2395 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2396 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS		 2397 newSVOP(OP_CONST, 0,
2398 newSVpvn(sstr, attrstr-sstr)));
2399 }
2400 }
2401
2402 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2403 newSVpvs(ATTRSMODULE),
2fcb4757 2404 NULL, op_prepend_elem(OP_LIST,
be3174d2 2405 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2406 op_prepend_elem(OP_LIST,
be3174d2 2407 newSVOP(OP_CONST, 0,
ad64d0ec 2408 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2409 attrs)));
2410}
2411
09bef843 2412STATIC OP *
95f0a2f1 2413S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2414{
97aff369 2415 dVAR;
93a17b20 2416 I32 type;
a1fba7eb 2417 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2418
7918f24d
NC		 2419 PERL_ARGS_ASSERT_MY_KID;
2420
13765c85 2421 if (!o || (PL_parser && PL_parser->error_count))
11343788 2422 return o;
93a17b20 2423
bc61e325 2424 type = o->op_type;
eb8433b7
NC		 2425 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2426 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2427 return o;
2428 }
2429
93a17b20 2430 if (type == OP_LIST) {
6867be6d 2431 OP *kid;
11343788 2432 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2433 my_kid(kid, attrs, imopsp);
0865059d 2434 return o;
eb8433b7
NC		 2435 } else if (type == OP_UNDEF
2436#ifdef PERL_MAD
2437 || type == OP_STUB
2438#endif
2439 ) {
7766148a 2440 return o;
77ca0c92
LW		 2441 } else if (type == OP_RV2SV || /* "our" declaration */
2442 type == OP_RV2AV ||
2443 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2444 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2445 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2446 OP_DESC(o),
12bd6ede
DM		 2447 PL_parser->in_my == KEY_our
2448 ? "our"
2449 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2450 } else if (attrs) {
551405c4 2451 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2452 PL_parser->in_my = FALSE;
2453 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2454 apply_attrs(GvSTASH(gv),
2455 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2456 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2457 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
1ce0b88c
RGS		 2458 attrs, FALSE);
2459 }
192587c2 2460 o->op_private |= OPpOUR_INTRO;
77ca0c92 2461 return o;
95f0a2f1
SB		 2462 }
2463 else if (type != OP_PADSV &&
93a17b20
LW		 2464 type != OP_PADAV &&
2465 type != OP_PADHV &&
2466 type != OP_PUSHMARK)
2467 {
eb64745e 2468 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2469 OP_DESC(o),
12bd6ede
DM		 2470 PL_parser->in_my == KEY_our
2471 ? "our"
2472 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2473 return o;
93a17b20 2474 }
09bef843
SB		 2475 else if (attrs && type != OP_PUSHMARK) {
2476 HV *stash;
09bef843 2477
12bd6ede
DM		 2478 PL_parser->in_my = FALSE;
2479 PL_parser->in_my_stash = NULL;
eb64745e 2480
09bef843 2481 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2482 stash = PAD_COMPNAME_TYPE(o->op_targ);
2483 if (!stash)
09bef843 2484 stash = PL_curstash;
95f0a2f1 2485 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2486 }
11343788
MB		 2487 o->op_flags |= OPf_MOD;
2488 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2489 if (stately)
952306ac 2490 o->op_private |= OPpPAD_STATE;
11343788 2491 return o;
93a17b20
LW		 2492}
2493
2494OP *
09bef843
SB		 2495Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2496{
97aff369 2497 dVAR;
0bd48802 2498 OP *rops;
95f0a2f1
SB		 2499 int maybe_scalar = 0;
2500
7918f24d
NC		 2501 PERL_ARGS_ASSERT_MY_ATTRS;
2502
d2be0de5 2503/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2504 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2505#if 0
09bef843
SB		 2506 if (o->op_flags & OPf_PARENS)
2507 list(o);
95f0a2f1
SB		 2508 else
2509 maybe_scalar = 1;
d2be0de5
YST		 2510#else
2511 maybe_scalar = 1;
2512#endif
09bef843
SB		 2513 if (attrs)
2514 SAVEFREEOP(attrs);
5f66b61c 2515 rops = NULL;
95f0a2f1
SB		 2516 o = my_kid(o, attrs, &rops);
2517 if (rops) {
2518 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2519 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB		 2520 o->op_private |= OPpLVAL_INTRO;
2521 }
f5d1ed10
FC		 2522 else {
2523 /* The listop in rops might have a pushmark at the beginning,
2524 which will mess up list assignment. */
2525 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2526 if (rops->op_type == OP_LIST &&
2527 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2528 {
2529 OP * const pushmark = lrops->op_first;
2530 lrops->op_first = pushmark->op_sibling;
2531 op_free(pushmark);
2532 }
2fcb4757 2533 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2534 }
95f0a2f1 2535 }
12bd6ede
DM		 2536 PL_parser->in_my = FALSE;
2537 PL_parser->in_my_stash = NULL;
eb64745e 2538 return o;
09bef843
SB		 2539}
2540
2541OP *
864dbfa3 2542Perl_sawparens(pTHX_ OP *o)
79072805 2543{
96a5add6 2544 PERL_UNUSED_CONTEXT;
79072805
LW		 2545 if (o)
2546 o->op_flags |= OPf_PARENS;
2547 return o;
2548}
2549
2550OP *
864dbfa3 2551Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2552{
11343788 2553 OP *o;
59f00321 2554 bool ismatchop = 0;
1496a290
AL		 2555 const OPCODE ltype = left->op_type;
2556 const OPCODE rtype = right->op_type;
79072805 2557
7918f24d
NC		 2558 PERL_ARGS_ASSERT_BIND_MATCH;
2559
1496a290
AL		 2560 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2561 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2562 {
1496a290 2563 const char * const desc
bb16bae8
FC		 2564 = PL_op_desc[(
2565 rtype == OP_SUBST || rtype == OP_TRANS
2566 || rtype == OP_TRANSR
2567 )
666ea192 2568 ? (int)rtype : OP_MATCH];
c6771ab6
FC		 2569 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2570 GV *gv;
2571 SV * const name =
2572 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2573 ? cUNOPx(left)->op_first->op_type == OP_GV
2574 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2575 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2576 : NULL
ba510004
FC		 2577 : varname(
2578 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2579 );
c6771ab6
FC		 2580 if (name)
2581 Perl_warner(aTHX_ packWARN(WARN_MISC),
2582 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2583 desc, name, name);
2584 else {
2585 const char * const sample = (isary
666ea192 2586 ? "@array" : "%hash");
c6771ab6 2587 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2588 "Applying %s to %s will act on scalar(%s)",
599cee73 2589 desc, sample, sample);
c6771ab6 2590 }
2ae324a7 2591 }
2592
1496a290 2593 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2594 cSVOPx(right)->op_private & OPpCONST_BARE &&
2595 cSVOPx(right)->op_private & OPpCONST_STRICT)
2596 {
2597 no_bareword_allowed(right);
2598 }
2599
bb16bae8 2600 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC		 2601 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2602 type == OP_NOT)
2603 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC		 2604 if (rtype == OP_TRANSR && type == OP_NOT)
2605 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2606
2474a784
FC		 2607 ismatchop = (rtype == OP_MATCH ||
2608 rtype == OP_SUBST ||
bb16bae8 2609 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2610 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2611 if (ismatchop && right->op_private & OPpTARGET_MY) {
2612 right->op_targ = 0;
2613 right->op_private &= ~OPpTARGET_MY;
2614 }
2615 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2616 OP *newleft;
2617
79072805 2618 right->op_flags |= OPf_STACKED;
bb16bae8 2619 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2620 ! (rtype == OP_TRANS &&
4f4d7508
DC		 2621 right->op_private & OPpTRANS_IDENTICAL) &&
2622 ! (rtype == OP_SUBST &&
2623 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2624 newleft = op_lvalue(left, rtype);
1496a290
AL		 2625 else
2626 newleft = left;
bb16bae8 2627 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2628 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2629 else
2fcb4757 2630 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2631 if (type == OP_NOT)
11343788
MB		 2632 return newUNOP(OP_NOT, 0, scalar(o));
2633 return o;
79072805
LW		 2634 }
2635 else
2636 return bind_match(type, left,
131b3ad0 2637 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
79072805
LW		 2638}
2639
2640OP *
864dbfa3 2641Perl_invert(pTHX_ OP *o)
79072805 2642{
11343788 2643 if (!o)
1d866c12 2644 return NULL;
11343788 2645 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2646}
2647
3ad73efd
Z		 2648/*
2649=for apidoc Amx|OP *|op_scope|OP *o
2650
2651Wraps up an op tree with some additional ops so that at runtime a dynamic
2652scope will be created. The original ops run in the new dynamic scope,
2653and then, provided that they exit normally, the scope will be unwound.
2654The additional ops used to create and unwind the dynamic scope will
2655normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2656instead if the ops are simple enough to not need the full dynamic scope
2657structure.
2658
2659=cut
2660*/
2661
79072805 2662OP *
3ad73efd 2663Perl_op_scope(pTHX_ OP *o)
79072805 2664{
27da23d5 2665 dVAR;
79072805 2666 if (o) {
3280af22 2667 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2fcb4757 2668 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2669 o->op_type = OP_LEAVE;
22c35a8c 2670 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2671 }
fdb22418
HS		 2672 else if (o->op_type == OP_LINESEQ) {
2673 OP *kid;
2674 o->op_type = OP_SCOPE;
2675 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2676 kid = ((LISTOP*)o)->op_first;
59110972 2677 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2678 op_null(kid);
59110972
RH		 2679
2680 /* The following deals with things like 'do {1 for 1}' */
2681 kid = kid->op_sibling;
2682 if (kid &&
2683 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2684 op_null(kid);
2685 }
463ee0b2 2686 }
fdb22418 2687 else
5f66b61c 2688 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2689 }
2690 return o;
2691}
1930840b 2692
a0d0e21e 2693int
864dbfa3 2694Perl_block_start(pTHX_ int full)
79072805 2695{
97aff369 2696 dVAR;
73d840c0 2697 const int retval = PL_savestack_ix;
1930840b 2698
dd2155a4 2699 pad_block_start(full);
b3ac6de7 2700 SAVEHINTS();
3280af22 2701 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2702 SAVECOMPILEWARNINGS();
72dc9ed5 2703 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2704
a88d97bf 2705 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2706
a0d0e21e
LW		 2707 return retval;
2708}
2709
2710OP*
864dbfa3 2711Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2712{
97aff369 2713 dVAR;
6867be6d 2714 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b
BM		 2715 OP* retval = scalarseq(seq);
2716
a88d97bf 2717 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2718
e9818f4e 2719 LEAVE_SCOPE(floor);
623e6609 2720 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2721 if (needblockscope)
3280af22 2722 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
dd2155a4 2723 pad_leavemy();
1930840b 2724
a88d97bf 2725 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2726
a0d0e21e
LW		 2727 return retval;
2728}
2729
fd85fad2
BM		 2730/*
2731=head1 Compile-time scope hooks
2732
3e4ddde5 2733=for apidoc Aox||blockhook_register
fd85fad2
BM		 2734
2735Register a set of hooks to be called when the Perl lexical scope changes
2736at compile time. See L<perlguts/"Compile-time scope hooks">.
2737
2738=cut
2739*/
2740
bb6c22e7
BM		 2741void
2742Perl_blockhook_register(pTHX_ BHK *hk)
2743{
2744 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2745
2746 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2747}
2748
76e3520e 2749STATIC OP *
cea2e8a9 2750S_newDEFSVOP(pTHX)
54b9620d 2751{
97aff369 2752 dVAR;
cc76b5cc 2753 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 2754 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2755 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2756 }
2757 else {
551405c4 2758 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2759 o->op_targ = offset;
2760 return o;
2761 }
54b9620d
MB		 2762}
2763
a0d0e21e 2764void
864dbfa3 2765Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2766{
97aff369 2767 dVAR;
7918f24d
NC		 2768
2769 PERL_ARGS_ASSERT_NEWPROG;
2770
3280af22 2771 if (PL_in_eval) {
86a64801 2772 PERL_CONTEXT *cx;
63429d50 2773 I32 i;
b295d113
TH		 2774 if (PL_eval_root)
2775 return;
faef0170
HS		 2776 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2777 ((PL_in_eval & EVAL_KEEPERR)
2778 ? OPf_SPECIAL : 0), o);
86a64801
GG		 2779
2780 cx = &cxstack[cxstack_ix];
2781 assert(CxTYPE(cx) == CXt_EVAL);
2782
2783 if ((cx->blk_gimme & G_WANT) == G_VOID)
2784 scalarvoid(PL_eval_root);
2785 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
2786 list(PL_eval_root);
2787 else
2788 scalar(PL_eval_root);
2789
5983a79d
BM		 2790 /* don't use LINKLIST, since PL_eval_root might indirect through
2791 * a rather expensive function call and LINKLIST evaluates its
2792 * argument more than once */
2793 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS		 2794 PL_eval_root->op_private |= OPpREFCOUNTED;
2795 OpREFCNT_set(PL_eval_root, 1);
3280af22 2796 PL_eval_root->op_next = 0;
63429d50
FC		 2797 i = PL_savestack_ix;
2798 SAVEFREEOP(o);
2799 ENTER;
a2efc822 2800 CALL_PEEP(PL_eval_start);
86a64801 2801 finalize_optree(PL_eval_root);
63429d50
FC		 2802 LEAVE;
2803 PL_savestack_ix = i;
a0d0e21e
LW		 2804 }
2805 else {
6be89cf9
AE		 2806 if (o->op_type == OP_STUB) {
2807 PL_comppad_name = 0;
2808 PL_compcv = 0;
d2c837a0 2809 S_op_destroy(aTHX_ o);
a0d0e21e 2810 return;
6be89cf9 2811 }
3ad73efd 2812 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS		 2813 PL_curcop = &PL_compiling;
2814 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 2815 PL_main_root->op_private |= OPpREFCOUNTED;
2816 OpREFCNT_set(PL_main_root, 1);
3280af22 2817 PL_main_root->op_next = 0;
a2efc822 2818 CALL_PEEP(PL_main_start);
d164302a 2819 finalize_optree(PL_main_root);
3280af22 2820 PL_compcv = 0;
3841441e 2821
4fdae800 2822 /* Register with debugger */
84902520 2823 if (PERLDB_INTER) {
b96d8cd9 2824 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 2825 if (cv) {
2826 dSP;
924508f0 2827 PUSHMARK(SP);
ad64d0ec 2828 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 2829 PUTBACK;
ad64d0ec 2830 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 2831 }
2832 }
79072805 2833 }
79072805
LW		 2834}
2835
2836OP *
864dbfa3 2837Perl_localize(pTHX_ OP *o, I32 lex)
79072805 2838{
97aff369 2839 dVAR;
7918f24d
NC		 2840
2841 PERL_ARGS_ASSERT_LOCALIZE;
2842
79072805 2843 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 2844/* [perl #17376]: this appears to be premature, and results in code such as
2845 C< our(%x); > executing in list mode rather than void mode */
2846#if 0
79072805 2847 list(o);
d2be0de5 2848#else
6f207bd3 2849 NOOP;
d2be0de5 2850#endif
8990e307 2851 else {
f06b5848
DM		 2852 if ( PL_parser->bufptr > PL_parser->oldbufptr
2853 && PL_parser->bufptr[-1] == ','
041457d9 2854 && ckWARN(WARN_PARENTHESIS))
64420d0d 2855 {
f06b5848 2856 char *s = PL_parser->bufptr;
bac662ee 2857 bool sigil = FALSE;
64420d0d 2858
8473848f 2859 /* some heuristics to detect a potential error */
bac662ee 2860 while (*s && (strchr(", \t\n", *s)))
64420d0d 2861 s++;
8473848f 2862
bac662ee
TS		 2863 while (1) {
2864 if (*s && strchr("@$%*", *s) && *++s
2865 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2866 s++;
2867 sigil = TRUE;
2868 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2869 s++;
2870 while (*s && (strchr(", \t\n", *s)))
2871 s++;
2872 }
2873 else
2874 break;
2875 }
2876 if (sigil && (*s == ';' || *s == '=')) {
2877 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 2878 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 2879 lex
2880 ? (PL_parser->in_my == KEY_our
2881 ? "our"
2882 : PL_parser->in_my == KEY_state
2883 ? "state"
2884 : "my")
2885 : "local");
8473848f 2886 }
8990e307
LW		 2887 }
2888 }
93a17b20 2889 if (lex)
eb64745e 2890 o = my(o);
93a17b20 2891 else
3ad73efd 2892 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 2893 PL_parser->in_my = FALSE;
2894 PL_parser->in_my_stash = NULL;
eb64745e 2895 return o;
79072805
LW		 2896}
2897
2898OP *
864dbfa3 2899Perl_jmaybe(pTHX_ OP *o)
79072805 2900{
7918f24d
NC		 2901 PERL_ARGS_ASSERT_JMAYBE;
2902
79072805 2903 if (o->op_type == OP_LIST) {
fafc274c 2904 OP * const o2
d4c19fe8 2905 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 2906 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW		 2907 }
2908 return o;
2909}
2910
985b9e54
GG		 2911PERL_STATIC_INLINE OP *
2912S_op_std_init(pTHX_ OP *o)
2913{
2914 I32 type = o->op_type;
2915
2916 PERL_ARGS_ASSERT_OP_STD_INIT;
2917
2918 if (PL_opargs[type] & OA_RETSCALAR)
2919 scalar(o);
2920 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2921 o->op_targ = pad_alloc(type, SVs_PADTMP);
2922
2923 return o;
2924}
2925
2926PERL_STATIC_INLINE OP *
2927S_op_integerize(pTHX_ OP *o)
2928{
2929 I32 type = o->op_type;
2930
2931 PERL_ARGS_ASSERT_OP_INTEGERIZE;
2932
2933 /* integerize op, unless it happens to be C<-foo>.
2934 * XXX should pp_i_negate() do magic string negation instead? */
2935 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2936 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2937 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2938 {
f5f19483 2939 dVAR;
985b9e54
GG		 2940 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2941 }
2942
2943 if (type == OP_NEGATE)
2944 /* XXX might want a ck_negate() for this */
2945 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2946
2947 return o;
2948}
2949
1f676739 2950static OP *
b7783a12 2951S_fold_constants(pTHX_ register OP *o)
79072805 2952{
27da23d5 2953 dVAR;
001d637e 2954 register OP * VOL curop;
eb8433b7 2955 OP *newop;
8ea43dc8 2956 VOL I32 type = o->op_type;
e3cbe32f 2957 SV * VOL sv = NULL;
b7f7fd0b
NC		 2958 int ret = 0;
2959 I32 oldscope;
2960 OP *old_next;
5f2d9966
DM		 2961 SV * const oldwarnhook = PL_warnhook;
2962 SV * const olddiehook = PL_diehook;
c427f4d2 2963 COP not_compiling;
b7f7fd0b 2964 dJMPENV;
79072805 2965
7918f24d
NC		 2966 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2967
22c35a8c 2968 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 2969 goto nope;
2970
de939608 2971 switch (type) {
de939608
CS		 2972 case OP_UCFIRST:
2973 case OP_LCFIRST:
2974 case OP_UC:
2975 case OP_LC:
69dcf70c
MB		 2976 case OP_SLT:
2977 case OP_SGT:
2978 case OP_SLE:
2979 case OP_SGE:
2980 case OP_SCMP:
b3fd6149 2981 case OP_SPRINTF:
2de3dbcc 2982 /* XXX what about the numeric ops? */
82ad65bb 2983 if (IN_LOCALE_COMPILETIME)
de939608 2984 goto nope;
553e7bb0 2985 break;
de939608
CS		 2986 }
2987
13765c85 2988 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 2989 goto nope; /* Don't try to run w/ errors */
2990
79072805 2991 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 2992 const OPCODE type = curop->op_type;
2993 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2994 type != OP_LIST &&
2995 type != OP_SCALAR &&
2996 type != OP_NULL &&
2997 type != OP_PUSHMARK)
7a52d87a 2998 {
79072805
LW		 2999 goto nope;
3000 }
3001 }
3002
3003 curop = LINKLIST(o);
b7f7fd0b 3004 old_next = o->op_next;
79072805 3005 o->op_next = 0;
533c011a 3006 PL_op = curop;
b7f7fd0b
NC		 3007
3008 oldscope = PL_scopestack_ix;
edb2152a 3009 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3010
c427f4d2
NC		 3011 /* Verify that we don't need to save it: */
3012 assert(PL_curcop == &PL_compiling);
3013 StructCopy(&PL_compiling, &not_compiling, COP);
3014 PL_curcop = &not_compiling;
3015 /* The above ensures that we run with all the correct hints of the
3016 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3017 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 3018 PL_warnhook = PERL_WARNHOOK_FATAL;
3019 PL_diehook = NULL;
b7f7fd0b
NC		 3020 JMPENV_PUSH(ret);
3021
3022 switch (ret) {
3023 case 0:
3024 CALLRUNOPS(aTHX);
3025 sv = *(PL_stack_sp--);
523a0f0c
NC		 3026 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3027#ifdef PERL_MAD
3028 /* Can't simply swipe the SV from the pad, because that relies on
3029 the op being freed "real soon now". Under MAD, this doesn't
3030 happen (see the #ifdef below). */
3031 sv = newSVsv(sv);
3032#else
b7f7fd0b 3033 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC		 3034#endif
3035 }
b7f7fd0b
NC		 3036 else if (SvTEMP(sv)) { /* grab mortal temp? */
3037 SvREFCNT_inc_simple_void(sv);
3038 SvTEMP_off(sv);
3039 }
3040 break;
3041 case 3:
3042 /* Something tried to die. Abandon constant folding. */
3043 /* Pretend the error never happened. */
ab69dbc2 3044 CLEAR_ERRSV();
b7f7fd0b
NC		 3045 o->op_next = old_next;
3046 break;
3047 default:
3048 JMPENV_POP;
5f2d9966
DM		 3049 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3050 PL_warnhook = oldwarnhook;
3051 PL_diehook = olddiehook;
3052 /* XXX note that this croak may fail as we've already blown away
3053 * the stack - eg any nested evals */
b7f7fd0b
NC		 3054 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3055 }
b7f7fd0b 3056 JMPENV_POP;
5f2d9966
DM		 3057 PL_warnhook = oldwarnhook;
3058 PL_diehook = olddiehook;
c427f4d2 3059 PL_curcop = &PL_compiling;
edb2152a
NC		 3060
3061 if (PL_scopestack_ix > oldscope)
3062 delete_eval_scope();
eb8433b7 3063
b7f7fd0b
NC		 3064 if (ret)
3065 goto nope;
3066
eb8433b7 3067#ifndef PERL_MAD
79072805 3068 op_free(o);
eb8433b7 3069#endif
de5e01c2 3070 assert(sv);
79072805 3071 if (type == OP_RV2GV)
159b6efe 3072 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3073 else
ad64d0ec 3074 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
eb8433b7
NC		 3075 op_getmad(o,newop,'f');
3076 return newop;
aeea060c 3077
b7f7fd0b 3078 nope:
79072805
LW		 3079 return o;
3080}
3081
1f676739 3082static OP *
b7783a12 3083S_gen_constant_list(pTHX_ register OP *o)
79072805 3084{
27da23d5 3085 dVAR;
79072805 3086 register OP *curop;
6867be6d 3087 const I32 oldtmps_floor = PL_tmps_floor;
79072805 3088
a0d0e21e 3089 list(o);
13765c85 3090 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3091 return o; /* Don't attempt to run with errors */
3092
533c011a 3093 PL_op = curop = LINKLIST(o);
a0d0e21e 3094 o->op_next = 0;
a2efc822 3095 CALL_PEEP(curop);
897d3989 3096 Perl_pp_pushmark(aTHX);
cea2e8a9 3097 CALLRUNOPS(aTHX);
533c011a 3098 PL_op = curop;
78c72037
NC		 3099 assert (!(curop->op_flags & OPf_SPECIAL));
3100 assert(curop->op_type == OP_RANGE);
897d3989 3101 Perl_pp_anonlist(aTHX);
3280af22 3102 PL_tmps_floor = oldtmps_floor;
79072805
LW		 3103
3104 o->op_type = OP_RV2AV;
22c35a8c 3105 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 3106 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3107 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3108 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3109 curop = ((UNOP*)o)->op_first;
b37c2d43 3110 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 3111#ifdef PERL_MAD
3112 op_getmad(curop,o,'O');
3113#else
79072805 3114 op_free(curop);
eb8433b7 3115#endif
5983a79d 3116 LINKLIST(o);
79072805
LW		 3117 return list(o);
3118}
3119
3120OP *
864dbfa3 3121Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3122{
27da23d5 3123 dVAR;
d67594ff 3124 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3125 if (!o || o->op_type != OP_LIST)
5f66b61c 3126 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3127 else
5dc0d613 3128 o->op_flags &= ~OPf_WANT;
79072805 3129
22c35a8c 3130 if (!(PL_opargs[type] & OA_MARK))
93c66552 3131 op_null(cLISTOPo->op_first);
bf0571fd
FC		 3132 else {
3133 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3134 if (kid2 && kid2->op_type == OP_COREARGS) {
3135 op_null(cLISTOPo->op_first);
3136 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3137 }
3138 }
8990e307 3139
eb160463 3140 o->op_type = (OPCODE)type;
22c35a8c 3141 o->op_ppaddr = PL_ppaddr[type];
11343788 3142 o->op_flags |= flags;
79072805 3143
11343788 3144 o = CHECKOP(type, o);
fe2774ed 3145 if (o->op_type != (unsigned)type)
11343788 3146 return o;
79072805 3147
985b9e54 3148 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 3149}
3150
2fcb4757
Z		 3151/*
3152=head1 Optree Manipulation Functions
3153*/
3154
79072805
LW		 3155/* List constructors */
3156
2fcb4757
Z		 3157/*
3158=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3159
3160Append an item to the list of ops contained directly within a list-type
3161op, returning the lengthened list. I<first> is the list-type op,
3162and I<last> is the op to append to the list. I<optype> specifies the
3163intended opcode for the list. If I<first> is not already a list of the
3164right type, it will be upgraded into one. If either I<first> or I<last>
3165is null, the other is returned unchanged.
3166
3167=cut
3168*/
3169
79072805 3170OP *
2fcb4757 3171Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3172{
3173 if (!first)
3174 return last;
8990e307
LW		 3175
3176 if (!last)
79072805 3177 return first;
8990e307 3178
fe2774ed 3179 if (first->op_type != (unsigned)type
155aba94
GS		 3180 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3181 {
3182 return newLISTOP(type, 0, first, last);
3183 }
79072805 3184
a0d0e21e
LW		 3185 if (first->op_flags & OPf_KIDS)
3186 ((LISTOP*)first)->op_last->op_sibling = last;
3187 else {
3188 first->op_flags |= OPf_KIDS;
3189 ((LISTOP*)first)->op_first = last;
3190 }
3191 ((LISTOP*)first)->op_last = last;
a0d0e21e 3192 return first;
79072805
LW		 3193}
3194
2fcb4757
Z		 3195/*
3196=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3197
3198Concatenate the lists of ops contained directly within two list-type ops,
3199returning the combined list. I<first> and I<last> are the list-type ops
3200to concatenate. I<optype> specifies the intended opcode for the list.
3201If either I<first> or I<last> is not already a list of the right type,
3202it will be upgraded into one. If either I<first> or I<last> is null,
3203the other is returned unchanged.
3204
3205=cut
3206*/
3207
79072805 3208OP *
2fcb4757 3209Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3210{
3211 if (!first)
2fcb4757 3212 return last;
8990e307
LW		 3213
3214 if (!last)
2fcb4757 3215 return first;
8990e307 3216
fe2774ed 3217 if (first->op_type != (unsigned)type)
2fcb4757 3218 return op_prepend_elem(type, first, last);
8990e307 3219
fe2774ed 3220 if (last->op_type != (unsigned)type)
2fcb4757 3221 return op_append_elem(type, first, last);
79072805 3222
2fcb4757
Z		 3223 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3224 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3225 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3226
eb8433b7 3227#ifdef PERL_MAD
2fcb4757
Z		 3228 if (((LISTOP*)last)->op_first && first->op_madprop) {
3229 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC		 3230 if (mp) {
3231 while (mp->mad_next)
3232 mp = mp->mad_next;
3233 mp->mad_next = first->op_madprop;
3234 }
3235 else {
2fcb4757 3236 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC		 3237 }
3238 }
3239 first->op_madprop = last->op_madprop;
3240 last->op_madprop = 0;
3241#endif
3242
2fcb4757 3243 S_op_destroy(aTHX_ last);
238a4c30 3244
2fcb4757 3245 return first;
79072805
LW		 3246}
3247
2fcb4757
Z		 3248/*
3249=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3250
3251Prepend an item to the list of ops contained directly within a list-type
3252op, returning the lengthened list. I<first> is the op to prepend to the
3253list, and I<last> is the list-type op. I<optype> specifies the intended
3254opcode for the list. If I<last> is not already a list of the right type,
3255it will be upgraded into one. If either I<first> or I<last> is null,
3256the other is returned unchanged.
3257
3258=cut
3259*/
3260
79072805 3261OP *
2fcb4757 3262Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3263{
3264 if (!first)
3265 return last;
8990e307
LW		 3266
3267 if (!last)
79072805 3268 return first;
8990e307 3269
fe2774ed 3270 if (last->op_type == (unsigned)type) {
8990e307
LW		 3271 if (type == OP_LIST) { /* already a PUSHMARK there */
3272 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3273 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 3274 if (!(first->op_flags & OPf_PARENS))
3275 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 3276 }
3277 else {
3278 if (!(last->op_flags & OPf_KIDS)) {
3279 ((LISTOP*)last)->op_last = first;
3280 last->op_flags |= OPf_KIDS;
3281 }
3282 first->op_sibling = ((LISTOP*)last)->op_first;
3283 ((LISTOP*)last)->op_first = first;
79072805 3284 }
117dada2 3285 last->op_flags |= OPf_KIDS;
79072805
LW		 3286 return last;
3287 }
3288
3289 return newLISTOP(type, 0, first, last);
3290}
3291
3292/* Constructors */
3293
eb8433b7
NC		 3294#ifdef PERL_MAD
3295
3296TOKEN *
3297Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3298{
3299 TOKEN *tk;
99129197 3300 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 3301 tk->tk_type = (OPCODE)optype;
3302 tk->tk_type = 12345;
3303 tk->tk_lval = lval;
3304 tk->tk_mad = madprop;
3305 return tk;
3306}
3307
3308void
3309Perl_token_free(pTHX_ TOKEN* tk)
3310{
7918f24d
NC		 3311 PERL_ARGS_ASSERT_TOKEN_FREE;
3312
eb8433b7
NC		 3313 if (tk->tk_type != 12345)
3314 return;
3315 mad_free(tk->tk_mad);
3316 Safefree(tk);
3317}
3318
3319void
3320Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3321{
3322 MADPROP* mp;
3323 MADPROP* tm;
7918f24d
NC		 3324
3325 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3326
eb8433b7
NC		 3327 if (tk->tk_type != 12345) {
3328 Perl_warner(aTHX_ packWARN(WARN_MISC),
3329 "Invalid TOKEN object ignored");
3330 return;
3331 }
3332 tm = tk->tk_mad;
3333 if (!tm)
3334 return;
3335
3336 /* faked up qw list? */
3337 if (slot == '(' &&
3338 tm->mad_type == MAD_SV &&
d503a9ba 3339 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 3340 slot = 'x';
3341
3342 if (o) {
3343 mp = o->op_madprop;
3344 if (mp) {
3345 for (;;) {
3346 /* pretend constant fold didn't happen? */
3347 if (mp->mad_key == 'f' &&
3348 (o->op_type == OP_CONST ||
3349 o->op_type == OP_GV) )
3350 {
3351 token_getmad(tk,(OP*)mp->mad_val,slot);
3352 return;
3353 }
3354 if (!mp->mad_next)
3355 break;
3356 mp = mp->mad_next;
3357 }
3358 mp->mad_next = tm;
3359 mp = mp->mad_next;
3360 }
3361 else {
3362 o->op_madprop = tm;
3363 mp = o->op_madprop;
3364 }
3365 if (mp->mad_key == 'X')
3366 mp->mad_key = slot; /* just change the first one */
3367
3368 tk->tk_mad = 0;
3369 }
3370 else
3371 mad_free(tm);
3372 Safefree(tk);
3373}
3374
3375void
3376Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3377{
3378 MADPROP* mp;
3379 if (!from)
3380 return;
3381 if (o) {
3382 mp = o->op_madprop;
3383 if (mp) {
3384 for (;;) {
3385 /* pretend constant fold didn't happen? */
3386 if (mp->mad_key == 'f' &&
3387 (o->op_type == OP_CONST ||
3388 o->op_type == OP_GV) )
3389 {
3390 op_getmad(from,(OP*)mp->mad_val,slot);
3391 return;
3392 }
3393 if (!mp->mad_next)
3394 break;
3395 mp = mp->mad_next;
3396 }
3397 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3398 }
3399 else {
3400 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3401 }
3402 }
3403}
3404
3405void
3406Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
3407{
3408 MADPROP* mp;
3409 if (!from)
3410 return;
3411 if (o) {
3412 mp = o->op_madprop;
3413 if (mp) {
3414 for (;;) {
3415 /* pretend constant fold didn't happen? */
3416 if (mp->mad_key == 'f' &&
3417 (o->op_type == OP_CONST ||
3418 o->op_type == OP_GV) )
3419 {
3420 op_getmad(from,(OP*)mp->mad_val,slot);
3421 return;
3422 }
3423 if (!mp->mad_next)
3424 break;
3425 mp = mp->mad_next;
3426 }
3427 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
3428 }
3429 else {
3430 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
3431 }
3432 }
3433 else {
99129197
NC		 3434 PerlIO_printf(PerlIO_stderr(),
3435 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
eb8433b7
NC		 3436 op_free(from);
3437 }
3438}
3439
3440void
3441Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
3442{
3443 MADPROP* tm;
3444 if (!mp || !o)
3445 return;
3446 if (slot)
3447 mp->mad_key = slot;
3448 tm = o->op_madprop;
3449 o->op_madprop = mp;
3450 for (;;) {
3451 if (!mp->mad_next)
3452 break;
3453 mp = mp->mad_next;
3454 }
3455 mp->mad_next = tm;
3456}
3457
3458void
3459Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
3460{
3461 if (!o)
3462 return;
3463 addmad(tm, &(o->op_madprop), slot);
3464}
3465
3466void
3467Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
3468{
3469 MADPROP* mp;
3470 if (!tm || !root)
3471 return;
3472 if (slot)
3473 tm->mad_key = slot;
3474 mp = *root;
3475 if (!mp) {
3476 *root = tm;
3477 return;
3478 }
3479 for (;;) {
3480 if (!mp->mad_next)
3481 break;
3482 mp = mp->mad_next;
3483 }
3484 mp->mad_next = tm;
3485}
3486
3487MADPROP *
3488Perl_newMADsv(pTHX_ char key, SV* sv)
3489{
7918f24d
NC		 3490 PERL_ARGS_ASSERT_NEWMADSV;
3491
eb8433b7
NC		 3492 return newMADPROP(key, MAD_SV, sv, 0);
3493}
3494
3495MADPROP *
d503a9ba 3496Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
eb8433b7 3497{
c111d5f1 3498 MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
eb8433b7
NC		 3499 mp->mad_next = 0;
3500 mp->mad_key = key;
3501 mp->mad_vlen = vlen;
3502 mp->mad_type = type;
3503 mp->mad_val = val;
3504/* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
3505 return mp;
3506}
3507
3508void
3509Perl_mad_free(pTHX_ MADPROP* mp)
3510{
3511/* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
3512 if (!mp)
3513 return;
3514 if (mp->mad_next)
3515 mad_free(mp->mad_next);
bc177e6b 3516/* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
eb8433b7
NC		 3517 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
3518 switch (mp->mad_type) {
3519 case MAD_NULL:
3520 break;
3521 case MAD_PV:
3522 Safefree((char*)mp->mad_val);
3523 break;
3524 case MAD_OP:
3525 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
3526 op_free((OP*)mp->mad_val);
3527 break;
3528 case MAD_SV:
ad64d0ec 3529 sv_free(MUTABLE_SV(mp->mad_val));
eb8433b7
NC		 3530 break;
3531 default:
3532 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
3533 break;
3534 }
c111d5f1 3535 PerlMemShared_free(mp);
eb8433b7
NC		 3536}
3537
3538#endif
3539
d67eb5f4
Z		 3540/*
3541=head1 Optree construction
3542
3543=for apidoc Am|OP *|newNULLLIST
3544
3545Constructs, checks, and returns a new C<stub> op, which represents an
3546empty list expression.
3547
3548=cut
3549*/
3550
79072805 3551OP *
864dbfa3 3552Perl_newNULLLIST(pTHX)
79072805 3553{
8990e307
LW		 3554 return newOP(OP_STUB, 0);
3555}
3556
1f676739 3557static OP *
b7783a12 3558S_force_list(pTHX_ OP *o)
8990e307 3559{
11343788 3560 if (!o || o->op_type != OP_LIST)
5f66b61c 3561 o = newLISTOP(OP_LIST, 0, o, NULL);
93c66552 3562 op_null(o);
11343788 3563 return o;
79072805
LW		 3564}
3565
d67eb5f4
Z		 3566/*
3567=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
3568
3569Constructs, checks, and returns an op of any list type. I<type> is
3570the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3571C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
3572supply up to two ops to be direct children of the list op; they are
3573consumed by this function and become part of the constructed op tree.
3574
3575=cut
3576*/
3577
79072805 3578OP *
864dbfa3 3579Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
79072805 3580{
27da23d5 3581 dVAR;
79072805
LW		 3582 LISTOP *listop;
3583
e69777c1
GG		 3584 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
3585
b7dc083c 3586 NewOp(1101, listop, 1, LISTOP);
79072805 3587
eb160463 3588 listop->op_type = (OPCODE)type;
22c35a8c 3589 listop->op_ppaddr = PL_ppaddr[type];
117dada2
SM		 3590 if (first || last)
3591 flags |= OPf_KIDS;
eb160463 3592 listop->op_flags = (U8)flags;
79072805
LW		 3593
3594 if (!last && first)
3595 last = first;
3596 else if (!first && last)
3597 first = last;
8990e307
LW		 3598 else if (first)
3599 first->op_sibling = last;
79072805
LW		 3600 listop->op_first = first;
3601 listop->op_last = last;
8990e307 3602 if (type == OP_LIST) {
551405c4 3603 OP* const pushop = newOP(OP_PUSHMARK, 0);
8990e307
LW		 3604 pushop->op_sibling = first;
3605 listop->op_first = pushop;
3606 listop->op_flags |= OPf_KIDS;
3607 if (!last)
3608 listop->op_last = pushop;
3609 }
79072805 3610
463d09e6 3611 return CHECKOP(type, listop);
79072805
LW		 3612}
3613
d67eb5f4
Z		 3614/*
3615=for apidoc Am|OP *|newOP|I32 type|I32 flags
3616
3617Constructs, checks, and returns an op of any base type (any type that
3618has no extra fields). I<type> is the opcode. I<flags> gives the
3619eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
3620of C<op_private>.
3621
3622=cut
3623*/
3624
79072805 3625OP *
864dbfa3 3626Perl_newOP(pTHX_ I32 type, I32 flags)
79072805 3627{
27da23d5 3628 dVAR;
11343788 3629 OP *o;
e69777c1 3630
7d789282
FC		 3631 if (type == -OP_ENTEREVAL) {
3632 type = OP_ENTEREVAL;
3633 flags |= OPpEVAL_BYTES<<8;
3634 }
3635
e69777c1
GG		 3636 assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
3637 || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
3638 || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
3639 || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
3640
b7dc083c 3641 NewOp(1101, o, 1, OP);
eb160463 3642 o->op_type = (OPCODE)type;
22c35a8c 3643 o->op_ppaddr = PL_ppaddr[type];
eb160463 3644 o->op_flags = (U8)flags;
670f3923
DM		 3645 o->op_latefree = 0;
3646 o->op_latefreed = 0;
7e5d8ed2 3647 o->op_attached = 0;
79072805 3648
11343788 3649 o->op_next = o;
eb160463 3650 o->op_private = (U8)(0 | (flags >> 8));
22c35a8c 3651 if (PL_opargs[type] & OA_RETSCALAR)
11343788 3652 scalar(o);
22c35a8c 3653 if (PL_opargs[type] & OA_TARGET)
11343788
MB		 3654 o->op_targ = pad_alloc(type, SVs_PADTMP);
3655 return CHECKOP(type, o);
79072805
LW		 3656}
3657
d67eb5f4
Z		 3658/*
3659=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
3660
3661Constructs, checks, and returns an op of any unary type. I<type> is
3662the opcode. I<flags> gives the eight bits of C<op_flags>, except that
3663C<OPf_KIDS> will be set automatically if required, and, shifted up eight