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