This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Improved struct pmop alignment fix - avoid the slow path on 64 bit systems.
[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
314# define Slab_to_rw(op)
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
BF
550STATIC void
551S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
552{
553 PERL_ARGS_ASSERT_BAD_TYPE_SV;
554
555 yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
556 (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
8990e307
LW
557}
558
7a52d87a 559STATIC void
eb796c7f 560S_no_bareword_allowed(pTHX_ OP *o)
7a52d87a 561{
7918f24d
NC
562 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
563
eb8433b7
NC
564 if (PL_madskills)
565 return; /* various ok barewords are hidden in extra OP_NULL */
5a844595 566 qerror(Perl_mess(aTHX_
35c1215d 567 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
be2597df 568 SVfARG(cSVOPo_sv)));
eb796c7f 569 o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
7a52d87a
GS
570}
571
79072805
LW
572/* "register" allocation */
573
574PADOFFSET
d6447115 575Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
93a17b20 576{
97aff369 577 dVAR;
a0d0e21e 578 PADOFFSET off;
12bd6ede 579 const bool is_our = (PL_parser->in_my == KEY_our);
a0d0e21e 580
7918f24d
NC
581 PERL_ARGS_ASSERT_ALLOCMY;
582
48d0d1be 583 if (flags & ~SVf_UTF8)
d6447115
NC
584 Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
585 (UV)flags);
586
587 /* Until we're using the length for real, cross check that we're being
588 told the truth. */
589 assert(strlen(name) == len);
590
59f00321 591 /* complain about "my $<special_var>" etc etc */
d6447115 592 if (len &&
3edf23ff 593 !(is_our ||
155aba94 594 isALPHA(name[1]) ||
b14845b4 595 ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
d6447115 596 (name[1] == '_' && (*name == '$' || len > 2))))
834a4ddd 597 {
6b58708b 598 /* name[2] is true if strlen(name) > 2 */
b14845b4
FC
599 if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
600 && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
d6447115
NC
601 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
602 name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
aab6a793 603 PL_parser->in_my == KEY_state ? "state" : "my"));
d1544d85 604 } else {
ce16c625
BF
605 yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
606 PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
46fc3d4c 607 }
a0d0e21e 608 }
4055dbce
RS
609 else if (len == 2 && name[1] == '_' && !is_our)
610 /* diag_listed_as: Use of my $_ is experimental */
611 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
612 "Use of %s $_ is experimental",
613 PL_parser->in_my == KEY_state
614 ? "state"
615 : "my");
748a9306 616
dd2155a4 617 /* allocate a spare slot and store the name in that slot */
93a17b20 618
cc76b5cc 619 off = pad_add_name_pvn(name, len,
48d0d1be
BF
620 (is_our ? padadd_OUR :
621 PL_parser->in_my == KEY_state ? padadd_STATE : 0)
622 | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
12bd6ede 623 PL_parser->in_my_stash,
3edf23ff 624 (is_our
133706a6
RGS
625 /* $_ is always in main::, even with our */
626 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
5c284bb0 627 : NULL
cca43f78 628 )
dd2155a4 629 );
a74073ad
DM
630 /* anon sub prototypes contains state vars should always be cloned,
631 * otherwise the state var would be shared between anon subs */
632
633 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
634 CvCLONE_on(PL_compcv);
635
dd2155a4 636 return off;
79072805
LW
637}
638
c0b8aebd
FC
639/*
640=for apidoc alloccopstash
641
642Available only under threaded builds, this function allocates an entry in
643C<PL_stashpad> for the stash passed to it.
644
645=cut
646*/
647
d4d03940
FC
648#ifdef USE_ITHREADS
649PADOFFSET
650Perl_alloccopstash(pTHX_ HV *hv)
651{
652 PADOFFSET off = 0, o = 1;
653 bool found_slot = FALSE;
654
655 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
656
657 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
658
659 for (; o < PL_stashpadmax; ++o) {
660 if (PL_stashpad[o] == hv) return PL_stashpadix = o;
661 if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
662 found_slot = TRUE, off = o;
663 }
664 if (!found_slot) {
665 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
666 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
667 off = PL_stashpadmax;
668 PL_stashpadmax += 10;
669 }
670
671 PL_stashpad[PL_stashpadix = off] = hv;
672 return off;
673}
674#endif
675
d2c837a0
DM
676/* free the body of an op without examining its contents.
677 * Always use this rather than FreeOp directly */
678
4136a0f7 679static void
d2c837a0
DM
680S_op_destroy(pTHX_ OP *o)
681{
d2c837a0
DM
682 FreeOp(o);
683}
684
79072805
LW
685/* Destructor */
686
687void
864dbfa3 688Perl_op_free(pTHX_ OP *o)
79072805 689{
27da23d5 690 dVAR;
acb36ea4 691 OPCODE type;
79072805 692
8be227ab
FC
693 /* Though ops may be freed twice, freeing the op after its slab is a
694 big no-no. */
695 assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0);
8be227ab
FC
696 /* During the forced freeing of ops after compilation failure, kidops
697 may be freed before their parents. */
698 if (!o || o->op_type == OP_FREED)
79072805
LW
699 return;
700
67566ccd 701 type = o->op_type;
7934575e 702 if (o->op_private & OPpREFCOUNTED) {
67566ccd 703 switch (type) {
7934575e
GS
704 case OP_LEAVESUB:
705 case OP_LEAVESUBLV:
706 case OP_LEAVEEVAL:
707 case OP_LEAVE:
708 case OP_SCOPE:
709 case OP_LEAVEWRITE:
67566ccd
AL
710 {
711 PADOFFSET refcnt;
7934575e 712 OP_REFCNT_LOCK;
4026c95a 713 refcnt = OpREFCNT_dec(o);
7934575e 714 OP_REFCNT_UNLOCK;
bfd0ff22
NC
715 if (refcnt) {
716 /* Need to find and remove any pattern match ops from the list
717 we maintain for reset(). */
718 find_and_forget_pmops(o);
4026c95a 719 return;
67566ccd 720 }
bfd0ff22 721 }
7934575e
GS
722 break;
723 default:
724 break;
725 }
726 }
727
f37b8c3f
VP
728 /* Call the op_free hook if it has been set. Do it now so that it's called
729 * at the right time for refcounted ops, but still before all of the kids
730 * are freed. */
731 CALL_OPFREEHOOK(o);
732
11343788 733 if (o->op_flags & OPf_KIDS) {
eb578fdb 734 OP *kid, *nextkid;
11343788 735 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
85e6fe83 736 nextkid = kid->op_sibling; /* Get before next freeing kid */
79072805 737 op_free(kid);
85e6fe83 738 }
79072805 739 }
513f78f7
FC
740 if (type == OP_NULL)
741 type = (OPCODE)o->op_targ;
acb36ea4 742
9bcdb3dd
JH
743 if (o->op_slabbed) {
744 Slab_to_rw(OpSLAB(o));
745 }
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
PP
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
PP
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)) {
a52fe3ac
A
1397 /* perl4's way of mixing documentation and code
1398 (before the invention of POD) was based on a
1399 trick to mix nroff and perl code. The trick was
1400 built upon these three nroff macros being used in
1401 void context. The pink camel has the details in
1402 the script wrapman near page 319. */
6136c704
AL
1403 const char * const maybe_macro = SvPVX_const(sv);
1404 if (strnEQ(maybe_macro, "di", 2) ||
1405 strnEQ(maybe_macro, "ds", 2) ||
1406 strnEQ(maybe_macro, "ig", 2))
d4c19fe8 1407 useless = NULL;
919f76a3 1408 else {
d3bcd21f 1409 SV * const dsv = newSVpvs("");
095b19d1
NC
1410 useless_sv
1411 = Perl_newSVpvf(aTHX_
1412 "a constant (%s)",
1413 pv_pretty(dsv, maybe_macro,
1414 SvCUR(sv), 32, NULL, NULL,
1415 PERL_PV_PRETTY_DUMP
1416 | PERL_PV_ESCAPE_NOCLEAR
1417 | PERL_PV_ESCAPE_UNI_DETECT));
fc2b2dca 1418 SvREFCNT_dec_NN(dsv);
919f76a3 1419 }
d008e5eb 1420 }
919f76a3 1421 else if (SvOK(sv)) {
095b19d1 1422 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
919f76a3
RGS
1423 }
1424 else
1425 useless = "a constant (undef)";
8990e307
LW
1426 }
1427 }
93c66552 1428 op_null(o); /* don't execute or even remember it */
79072805
LW
1429 break;
1430
1431 case OP_POSTINC:
11343788 1432 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1433 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW
1434 break;
1435
1436 case OP_POSTDEC:
11343788 1437 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1438 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW
1439 break;
1440
679d6c4e
HS
1441 case OP_I_POSTINC:
1442 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1443 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1444 break;
1445
1446 case OP_I_POSTDEC:
1447 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1448 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1449 break;
1450
f2f8fd84
GG
1451 case OP_SASSIGN: {
1452 OP *rv2gv;
1453 UNOP *refgen, *rv2cv;
1454 LISTOP *exlist;
1455
1456 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1457 break;
1458
1459 rv2gv = ((BINOP *)o)->op_last;
1460 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1461 break;
1462
1463 refgen = (UNOP *)((BINOP *)o)->op_first;
1464
1465 if (!refgen || refgen->op_type != OP_REFGEN)
1466 break;
1467
1468 exlist = (LISTOP *)refgen->op_first;
1469 if (!exlist || exlist->op_type != OP_NULL
1470 || exlist->op_targ != OP_LIST)
1471 break;
1472
1473 if (exlist->op_first->op_type != OP_PUSHMARK)
1474 break;
1475
1476 rv2cv = (UNOP*)exlist->op_last;
1477
1478 if (rv2cv->op_type != OP_RV2CV)
1479 break;
1480
1481 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1482 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1483 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1484
1485 o->op_private |= OPpASSIGN_CV_TO_GV;
1486 rv2gv->op_private |= OPpDONT_INIT_GV;
1487 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1488
1489 break;
1490 }
1491
540dd770
GG
1492 case OP_AASSIGN: {
1493 inplace_aassign(o);
1494 break;
1495 }
1496
79072805
LW
1497 case OP_OR:
1498 case OP_AND:
edbe35ea
VP
1499 kid = cLOGOPo->op_first;
1500 if (kid->op_type == OP_NOT
1501 && (kid->op_flags & OPf_KIDS)
1502 && !PL_madskills) {
1503 if (o->op_type == OP_AND) {
1504 o->op_type = OP_OR;
1505 o->op_ppaddr = PL_ppaddr[OP_OR];
1506 } else {
1507 o->op_type = OP_AND;
1508 o->op_ppaddr = PL_ppaddr[OP_AND];
1509 }
1510 op_null(kid);
1511 }
1512
c963b151 1513 case OP_DOR:
79072805 1514 case OP_COND_EXPR:
0d863452
RH
1515 case OP_ENTERGIVEN:
1516 case OP_ENTERWHEN:
11343788 1517 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1518 scalarvoid(kid);
1519 break;
5aabfad6 1520
a0d0e21e 1521 case OP_NULL:
11343788 1522 if (o->op_flags & OPf_STACKED)
a0d0e21e 1523 break;
5aabfad6 1524 /* FALL THROUGH */
2ebea0a1
GS
1525 case OP_NEXTSTATE:
1526 case OP_DBSTATE:
79072805
LW
1527 case OP_ENTERTRY:
1528 case OP_ENTER:
11343788 1529 if (!(o->op_flags & OPf_KIDS))
79072805 1530 break;
54310121 1531 /* FALL THROUGH */
463ee0b2 1532 case OP_SCOPE:
79072805
LW
1533 case OP_LEAVE:
1534 case OP_LEAVETRY:
a0d0e21e 1535 case OP_LEAVELOOP:
79072805 1536 case OP_LINESEQ:
79072805 1537 case OP_LIST:
0d863452
RH
1538 case OP_LEAVEGIVEN:
1539 case OP_LEAVEWHEN:
11343788 1540 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1541 scalarvoid(kid);
1542 break;
c90c0ff4 1543 case OP_ENTEREVAL:
5196be3e 1544 scalarkids(o);
c90c0ff4 1545 break;
d6483035 1546 case OP_SCALAR:
5196be3e 1547 return scalar(o);
79072805 1548 }
095b19d1
NC
1549
1550 if (useless_sv) {
1551 /* mortalise it, in case warnings are fatal. */
1552 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1553 "Useless use of %"SVf" in void context",
1554 sv_2mortal(useless_sv));
1555 }
1556 else if (useless) {
1557 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1558 "Useless use of %s in void context",
1559 useless);
1560 }
11343788 1561 return o;
79072805
LW
1562}
1563
1f676739 1564static OP *
412da003 1565S_listkids(pTHX_ OP *o)
79072805 1566{
11343788 1567 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1568 OP *kid;
11343788 1569 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1570 list(kid);
1571 }
11343788 1572 return o;
79072805
LW
1573}
1574
1575OP *
864dbfa3 1576Perl_list(pTHX_ OP *o)
79072805 1577{
27da23d5 1578 dVAR;
79072805
LW
1579 OP *kid;
1580
a0d0e21e 1581 /* assumes no premature commitment */
13765c85
DM
1582 if (!o || (o->op_flags & OPf_WANT)
1583 || (PL_parser && PL_parser->error_count)
5dc0d613 1584 || o->op_type == OP_RETURN)
7e363e51 1585 {
11343788 1586 return o;
7e363e51 1587 }
79072805 1588
b162f9ea 1589 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1590 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1591 {
b162f9ea 1592 return o; /* As if inside SASSIGN */
7e363e51 1593 }
1c846c1f 1594
5dc0d613 1595 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1596
11343788 1597 switch (o->op_type) {
79072805
LW
1598 case OP_FLOP:
1599 case OP_REPEAT:
11343788 1600 list(cBINOPo->op_first);
79072805
LW
1601 break;
1602 case OP_OR:
1603 case OP_AND:
1604 case OP_COND_EXPR:
11343788 1605 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1606 list(kid);
1607 break;
1608 default:
1609 case OP_MATCH:
8782bef2 1610 case OP_QR:
79072805
LW
1611 case OP_SUBST:
1612 case OP_NULL:
11343788 1613 if (!(o->op_flags & OPf_KIDS))
79072805 1614 break;
11343788
MB
1615 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1616 list(cBINOPo->op_first);
1617 return gen_constant_list(o);
79072805
LW
1618 }
1619 case OP_LIST:
11343788 1620 listkids(o);
79072805
LW
1621 break;
1622 case OP_LEAVE:
1623 case OP_LEAVETRY:
5dc0d613 1624 kid = cLISTOPo->op_first;
54310121 1625 list(kid);
25b991bf
VP
1626 kid = kid->op_sibling;
1627 do_kids:
1628 while (kid) {
1629 OP *sib = kid->op_sibling;
c08f093b
VP
1630 if (sib && kid->op_type != OP_LEAVEWHEN)
1631 scalarvoid(kid);
1632 else
54310121 1633 list(kid);
25b991bf 1634 kid = sib;
54310121 1635 }
11206fdd 1636 PL_curcop = &PL_compiling;
54310121 1637 break;
748a9306 1638 case OP_SCOPE:
79072805 1639 case OP_LINESEQ:
25b991bf
VP
1640 kid = cLISTOPo->op_first;
1641 goto do_kids;
79072805 1642 }
11343788 1643 return o;
79072805
LW
1644}
1645
1f676739 1646static OP *
2dd5337b 1647S_scalarseq(pTHX_ OP *o)
79072805 1648{
97aff369 1649 dVAR;
11343788 1650 if (o) {
1496a290
AL
1651 const OPCODE type = o->op_type;
1652
1653 if (type == OP_LINESEQ || type == OP_SCOPE ||
1654 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1655 {
6867be6d 1656 OP *kid;
11343788 1657 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1658 if (kid->op_sibling) {
463ee0b2 1659 scalarvoid(kid);
ed6116ce 1660 }
463ee0b2 1661 }
3280af22 1662 PL_curcop = &PL_compiling;
79072805 1663 }
11343788 1664 o->op_flags &= ~OPf_PARENS;
3280af22 1665 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1666 o->op_flags |= OPf_PARENS;
79072805 1667 }
8990e307 1668 else
11343788
MB
1669 o = newOP(OP_STUB, 0);
1670 return o;
79072805
LW
1671}
1672
76e3520e 1673STATIC OP *
cea2e8a9 1674S_modkids(pTHX_ OP *o, I32 type)
79072805 1675{
11343788 1676 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1677 OP *kid;
11343788 1678 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1679 op_lvalue(kid, type);
79072805 1680 }
11343788 1681 return o;
79072805
LW
1682}
1683
3ad73efd 1684/*
d164302a
GG
1685=for apidoc finalize_optree
1686
1687This function finalizes the optree. Should be called directly after
1688the complete optree is built. It does some additional
1689checking which can't be done in the normal ck_xxx functions and makes
1690the tree thread-safe.
1691
1692=cut
1693*/
1694void
1695Perl_finalize_optree(pTHX_ OP* o)
1696{
1697 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1698
1699 ENTER;
1700 SAVEVPTR(PL_curcop);
1701
1702 finalize_op(o);
1703
1704 LEAVE;
1705}
1706
60dde6b2 1707STATIC void
d164302a
GG
1708S_finalize_op(pTHX_ OP* o)
1709{
1710 PERL_ARGS_ASSERT_FINALIZE_OP;
1711
1712#if defined(PERL_MAD) && defined(USE_ITHREADS)
1713 {
1714 /* Make sure mad ops are also thread-safe */
1715 MADPROP *mp = o->op_madprop;
1716 while (mp) {
1717 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1718 OP *prop_op = (OP *) mp->mad_val;
1719 /* We only need "Relocate sv to the pad for thread safety.", but this
1720 easiest way to make sure it traverses everything */
4dc304e0
FC
1721 if (prop_op->op_type == OP_CONST)
1722 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG
1723 finalize_op(prop_op);
1724 }
1725 mp = mp->mad_next;
1726 }
1727 }
1728#endif
1729
1730 switch (o->op_type) {
1731 case OP_NEXTSTATE:
1732 case OP_DBSTATE:
1733 PL_curcop = ((COP*)o); /* for warnings */
1734 break;
1735 case OP_EXEC:
ea31ed66
GG
1736 if ( o->op_sibling
1737 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
573d2b1a 1738 && ckWARN(WARN_EXEC))
d164302a 1739 {
ea31ed66
GG
1740 if (o->op_sibling->op_sibling) {
1741 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG
1742 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1743 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1744 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG
1745 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1746 "Statement unlikely to be reached");
1747 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1748 "\t(Maybe you meant system() when you said exec()?)\n");
1749 CopLINE_set(PL_curcop, oldline);
1750 }
1751 }
1752 }
1753 break;
1754
1755 case OP_GV:
1756 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1757 GV * const gv = cGVOPo_gv;
1758 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1759 /* XXX could check prototype here instead of just carping */
1760 SV * const sv = sv_newmortal();
1761 gv_efullname3(sv, gv, NULL);
1762 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1763 "%"SVf"() called too early to check prototype",
1764 SVfARG(sv));
1765 }
1766 }
1767 break;
1768
1769 case OP_CONST:
eb796c7f
GG
1770 if (cSVOPo->op_private & OPpCONST_STRICT)
1771 no_bareword_allowed(o);
1772 /* FALLTHROUGH */
d164302a
GG
1773#ifdef USE_ITHREADS
1774 case OP_HINTSEVAL:
1775 case OP_METHOD_NAMED:
1776 /* Relocate sv to the pad for thread safety.
1777 * Despite being a "constant", the SV is written to,
1778 * for reference counts, sv_upgrade() etc. */
1779 if (cSVOPo->op_sv) {
1780 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
1781 if (o->op_type != OP_METHOD_NAMED &&
1782 (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
1783 {
1784 /* If op_sv is already a PADTMP/MY then it is being used by
1785 * some pad, so make a copy. */
1786 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
e3918bb7 1787 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
d164302a
GG
1788 SvREFCNT_dec(cSVOPo->op_sv);
1789 }
1790 else if (o->op_type != OP_METHOD_NAMED
1791 && cSVOPo->op_sv == &PL_sv_undef) {
1792 /* PL_sv_undef is hack - it's unsafe to store it in the
1793 AV that is the pad, because av_fetch treats values of
1794 PL_sv_undef as a "free" AV entry and will merrily
1795 replace them with a new SV, causing pad_alloc to think
1796 that this pad slot is free. (When, clearly, it is not)
1797 */
1798 SvOK_off(PAD_SVl(ix));
1799 SvPADTMP_on(PAD_SVl(ix));
1800 SvREADONLY_on(PAD_SVl(ix));
1801 }
1802 else {
1803 SvREFCNT_dec(PAD_SVl(ix));
1804 SvPADTMP_on(cSVOPo->op_sv);
1805 PAD_SETSV(ix, cSVOPo->op_sv);
1806 /* XXX I don't know how this isn't readonly already. */
e3918bb7 1807 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
d164302a
GG
1808 }
1809 cSVOPo->op_sv = NULL;
1810 o->op_targ = ix;
1811 }
1812#endif
1813 break;
1814
1815 case OP_HELEM: {
1816 UNOP *rop;
1817 SV *lexname;
1818 GV **fields;
1819 SV **svp, *sv;
1820 const char *key = NULL;
1821 STRLEN keylen;
1822
1823 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1824 break;
1825
1826 /* Make the CONST have a shared SV */
1827 svp = cSVOPx_svp(((BINOP*)o)->op_last);
e3918bb7 1828 if ((!SvIsCOW(sv = *svp))
d164302a
GG
1829 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1830 key = SvPV_const(sv, keylen);
1831 lexname = newSVpvn_share(key,
1832 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1833 0);
fc2b2dca 1834 SvREFCNT_dec_NN(sv);
d164302a
GG
1835 *svp = lexname;
1836 }
1837
1838 if ((o->op_private & (OPpLVAL_INTRO)))
1839 break;
1840
1841 rop = (UNOP*)((BINOP*)o)->op_first;
1842 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1843 break;
1844 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1845 if (!SvPAD_TYPED(lexname))
1846 break;
1847 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1848 if (!fields || !GvHV(*fields))
1849 break;
1850 key = SvPV_const(*svp, keylen);
1851 if (!hv_fetch(GvHV(*fields), key,
1852 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1853 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1854 "in variable %"SVf" of type %"HEKf,
ce16c625 1855 SVfARG(*svp), SVfARG(lexname),
84cf752c 1856 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG
1857 }
1858 break;
1859 }
1860
1861 case OP_HSLICE: {
1862 UNOP *rop;
1863 SV *lexname;
1864 GV **fields;
1865 SV **svp;
1866 const char *key;
1867 STRLEN keylen;
1868 SVOP *first_key_op, *key_op;
1869
1870 if ((o->op_private & (OPpLVAL_INTRO))
1871 /* I bet there's always a pushmark... */
1872 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1873 /* hmmm, no optimization if list contains only one key. */
1874 break;
1875 rop = (UNOP*)((LISTOP*)o)->op_last;
1876 if (rop->op_type != OP_RV2HV)
1877 break;
1878 if (rop->op_first->op_type == OP_PADSV)
1879 /* @$hash{qw(keys here)} */
1880 rop = (UNOP*)rop->op_first;
1881 else {
1882 /* @{$hash}{qw(keys here)} */
1883 if (rop->op_first->op_type == OP_SCOPE
1884 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1885 {
1886 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1887 }
1888 else
1889 break;
1890 }
1891
1892 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1893 if (!SvPAD_TYPED(lexname))
1894 break;
1895 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1896 if (!fields || !GvHV(*fields))
1897 break;
1898 /* Again guessing that the pushmark can be jumped over.... */
1899 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1900 ->op_first->op_sibling;
1901 for (key_op = first_key_op; key_op;
1902 key_op = (SVOP*)key_op->op_sibling) {
1903 if (key_op->op_type != OP_CONST)
1904 continue;
1905 svp = cSVOPx_svp(key_op);
1906 key = SvPV_const(*svp, keylen);
1907 if (!hv_fetch(GvHV(*fields), key,
1908 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1909 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1910 "in variable %"SVf" of type %"HEKf,
ce16c625 1911 SVfARG(*svp), SVfARG(lexname),
84cf752c 1912 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG
1913 }
1914 }
1915 break;
1916 }
a7fd8ef6 1917
d164302a
GG
1918 case OP_SUBST: {
1919 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1920 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1921 break;
1922 }
1923 default:
1924 break;
1925 }
1926
1927 if (o->op_flags & OPf_KIDS) {
1928 OP *kid;
1929 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1930 finalize_op(kid);
1931 }
1932}
1933
1934/*
3ad73efd
Z
1935=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1936
1937Propagate lvalue ("modifiable") context to an op and its children.
1938I<type> represents the context type, roughly based on the type of op that
1939would do the modifying, although C<local()> is represented by OP_NULL,
1940because it has no op type of its own (it is signalled by a flag on
001c3c51
FC
1941the lvalue op).
1942
1943This function detects things that can't be modified, such as C<$x+1>, and
1944generates errors for them. For example, C<$x+1 = 2> would cause it to be
1945called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1946
1947It also flags things that need to behave specially in an lvalue context,
1948such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z
1949
1950=cut
1951*/
ddeae0f1 1952
79072805 1953OP *
d3d7d28f 1954Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 1955{
27da23d5 1956 dVAR;
79072805 1957 OP *kid;
ddeae0f1
DM
1958 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1959 int localize = -1;
79072805 1960
13765c85 1961 if (!o || (PL_parser && PL_parser->error_count))
11343788 1962 return o;
79072805 1963
b162f9ea 1964 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1965 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1966 {
b162f9ea 1967 return o;
7e363e51 1968 }
1c846c1f 1969
5c906035
GG
1970 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1971
69974ce6
FC
1972 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1973
11343788 1974 switch (o->op_type) {
68dc0745 1975 case OP_UNDEF:
3280af22 1976 PL_modcount++;
5dc0d613 1977 return o;
5f05dabc 1978 case OP_STUB:
58bde88d 1979 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc
PP
1980 break;
1981 goto nomod;
a0d0e21e 1982 case OP_ENTERSUB:
f79aa60b 1983 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB
1984 !(o->op_flags & OPf_STACKED)) {
1985 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC
1986 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1987 poses, so we need it clear. */
e26df76a 1988 o->op_private &= ~1;
22c35a8c 1989 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1990 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1991 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
1992 break;
1993 }
cd06dffe 1994 else { /* lvalue subroutine call */
777d9014
FC
1995 o->op_private |= OPpLVAL_INTRO
1996 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 1997 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1998 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
d0887bf3 1999 /* Potential lvalue context: */
cd06dffe
GS
2000 o->op_private |= OPpENTERSUB_INARGS;
2001 break;
2002 }
2003 else { /* Compile-time error message: */
2004 OP *kid = cUNOPo->op_first;
2005 CV *cv;
cd06dffe 2006
3ea285d1
AL
2007 if (kid->op_type != OP_PUSHMARK) {
2008 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2009 Perl_croak(aTHX_
2010 "panic: unexpected lvalue entersub "
2011 "args: type/targ %ld:%"UVuf,
2012 (long)kid->op_type, (UV)kid->op_targ);
2013 kid = kLISTOP->op_first;
2014 }
cd06dffe
GS
2015 while (kid->op_sibling)
2016 kid = kid->op_sibling;
2017 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS
2018 break; /* Postpone until runtime */
2019 }
b2ffa427 2020
cd06dffe
GS
2021 kid = kUNOP->op_first;
2022 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2023 kid = kUNOP->op_first;
b2ffa427 2024 if (kid->op_type == OP_NULL)
cd06dffe
GS
2025 Perl_croak(aTHX_
2026 "Unexpected constant lvalue entersub "
55140b79 2027 "entry via type/targ %ld:%"UVuf,
3d811634 2028 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 2029 if (kid->op_type != OP_GV) {
cd06dffe
GS
2030 break;
2031 }
b2ffa427 2032
638eceb6 2033 cv = GvCV(kGVOP_gv);
1c846c1f 2034 if (!cv)
da1dff94 2035 break;
cd06dffe
GS
2036 if (CvLVALUE(cv))
2037 break;
2038 }
2039 }
79072805
LW
2040 /* FALL THROUGH */
2041 default:
a0d0e21e 2042 nomod:
f5d552b4 2043 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2044 /* grep, foreach, subcalls, refgen */
145b2bbb
FC
2045 if (type == OP_GREPSTART || type == OP_ENTERSUB
2046 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 2047 break;
cea2e8a9 2048 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2049 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
2050 ? "do block"
2051 : (o->op_type == OP_ENTERSUB
2052 ? "non-lvalue subroutine call"
53e06cf0 2053 : OP_DESC(o))),
22c35a8c 2054 type ? PL_op_desc[type] : "local"));
11343788 2055 return o;
79072805 2056
a0d0e21e
LW
2057 case OP_PREINC:
2058 case OP_PREDEC:
2059 case OP_POW:
2060 case OP_MULTIPLY:
2061 case OP_DIVIDE:
2062 case OP_MODULO:
2063 case OP_REPEAT:
2064 case OP_ADD:
2065 case OP_SUBTRACT:
2066 case OP_CONCAT:
2067 case OP_LEFT_SHIFT:
2068 case OP_RIGHT_SHIFT:
2069 case OP_BIT_AND:
2070 case OP_BIT_XOR:
2071 case OP_BIT_OR:
2072 case OP_I_MULTIPLY:
2073 case OP_I_DIVIDE:
2074 case OP_I_MODULO:
2075 case OP_I_ADD:
2076 case OP_I_SUBTRACT:
11343788 2077 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2078 goto nomod;
3280af22 2079 PL_modcount++;
a0d0e21e 2080 break;
b2ffa427 2081
79072805 2082 case OP_COND_EXPR:
ddeae0f1 2083 localize = 1;
11343788 2084 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 2085 op_lvalue(kid, type);
79072805
LW
2086 break;
2087
2088 case OP_RV2AV:
2089 case OP_RV2HV:
11343788 2090 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2091 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2092 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW
2093 }
2094 /* FALL THROUGH */
79072805 2095 case OP_RV2GV:
5dc0d613 2096 if (scalar_mod_type(o, type))
3fe9a6f1 2097 goto nomod;
11343788 2098 ref(cUNOPo->op_first, o->op_type);
79072805 2099 /* FALL THROUGH */
79072805
LW
2100 case OP_ASLICE:
2101 case OP_HSLICE:
ddeae0f1 2102 localize = 1;
78f9721b
SM
2103 /* FALL THROUGH */
2104 case OP_AASSIGN:
631dbaa2
FC
2105 if (type == OP_LEAVESUBLV)
2106 o->op_private |= OPpMAYBE_LVSUB;
2107 /* FALL THROUGH */
93a17b20
LW
2108 case OP_NEXTSTATE:
2109 case OP_DBSTATE:
e6438c1a 2110 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2111 break;
28c5b5bc
RGS
2112 case OP_AV2ARYLEN:
2113 PL_hints |= HINT_BLOCK_SCOPE;
2114 if (type == OP_LEAVESUBLV)
2115 o->op_private |= OPpMAYBE_LVSUB;
2116 PL_modcount++;
2117 break;
463ee0b2 2118 case OP_RV2SV:
aeea060c 2119 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2120 localize = 1;
463ee0b2 2121 /* FALL THROUGH */
79072805 2122 case OP_GV:
3280af22 2123 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 2124 case OP_SASSIGN:
bf4b1e52
GS
2125 case OP_ANDASSIGN:
2126 case OP_ORASSIGN:
c963b151 2127 case OP_DORASSIGN:
ddeae0f1
DM
2128 PL_modcount++;
2129 break;
2130
8990e307 2131 case OP_AELEMFAST:
93bad3fd 2132 case OP_AELEMFAST_LEX:
6a077020 2133 localize = -1;
3280af22 2134 PL_modcount++;
8990e307
LW
2135 break;
2136
748a9306
LW
2137 case OP_PADAV:
2138 case OP_PADHV:
e6438c1a 2139 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
2140 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2141 return o; /* Treat \(@foo) like ordinary list. */
2142 if (scalar_mod_type(o, type))
3fe9a6f1 2143 goto nomod;
78f9721b
SM
2144 if (type == OP_LEAVESUBLV)
2145 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW
2146 /* FALL THROUGH */
2147 case OP_PADSV:
3280af22 2148 PL_modcount++;
ddeae0f1 2149 if (!type) /* local() */
5ede95a0
BF
2150 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2151 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW
2152 break;
2153
748a9306 2154 case OP_PUSHMARK:
ddeae0f1 2155 localize = 0;
748a9306 2156 break;
b2ffa427 2157
69969c6f 2158 case OP_KEYS:
d8065907 2159 case OP_RKEYS:
fad4a2e4 2160 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2161 goto nomod;
5d82c453
GA
2162 goto lvalue_func;
2163 case OP_SUBSTR:
2164 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2165 goto nomod;
5f05dabc 2166 /* FALL THROUGH */
a0d0e21e 2167 case OP_POS:
463ee0b2 2168 case OP_VEC:
fad4a2e4 2169 lvalue_func:
78f9721b
SM
2170 if (type == OP_LEAVESUBLV)
2171 o->op_private |= OPpMAYBE_LVSUB;
11343788 2172 if (o->op_flags & OPf_KIDS)
3ad73efd 2173 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 2174 break;
a0d0e21e 2175
463ee0b2
LW
2176 case OP_AELEM:
2177 case OP_HELEM:
11343788 2178 ref(cBINOPo->op_first, o->op_type);
68dc0745 2179 if (type == OP_ENTERSUB &&
5dc0d613
MB
2180 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2181 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
2182 if (type == OP_LEAVESUBLV)
2183 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2184 localize = 1;
3280af22 2185 PL_modcount++;
463ee0b2
LW
2186 break;
2187
2188 case OP_SCOPE:
2189 case OP_LEAVE:
2190 case OP_ENTER:
78f9721b 2191 case OP_LINESEQ:
ddeae0f1 2192 localize = 0;
11343788 2193 if (o->op_flags & OPf_KIDS)
3ad73efd 2194 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW
2195 break;
2196
2197 case OP_NULL:
ddeae0f1 2198 localize = 0;
638bc118
GS
2199 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2200 goto nomod;
2201 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2202 break;
11343788 2203 if (o->op_targ != OP_LIST) {
3ad73efd 2204 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW
2205 break;
2206 }
2207 /* FALL THROUGH */
463ee0b2 2208 case OP_LIST:
ddeae0f1 2209 localize = 0;
11343788 2210 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG
2211 /* elements might be in void context because the list is
2212 in scalar context or because they are attribute sub calls */
2213 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2214 op_lvalue(kid, type);
463ee0b2 2215 break;
78f9721b
SM
2216
2217 case OP_RETURN:
2218 if (type != OP_LEAVESUBLV)
2219 goto nomod;
3ad73efd 2220 break; /* op_lvalue()ing was handled by ck_return() */
1efec5ed
FC
2221
2222 case OP_COREARGS:
2223 return o;
463ee0b2 2224 }
58d95175 2225
8be1be90
AMS
2226 /* [20011101.069] File test operators interpret OPf_REF to mean that
2227 their argument is a filehandle; thus \stat(".") should not set
2228 it. AMS 20011102 */
2229 if (type == OP_REFGEN &&
ef69c8fc 2230 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS
2231 return o;
2232
2233 if (type != OP_LEAVESUBLV)
2234 o->op_flags |= OPf_MOD;
2235
2236 if (type == OP_AASSIGN || type == OP_SASSIGN)
2237 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM
2238 else if (!type) { /* local() */
2239 switch (localize) {
2240 case 1:
2241 o->op_private |= OPpLVAL_INTRO;
2242 o->op_flags &= ~OPf_SPECIAL;
2243 PL_hints |= HINT_BLOCK_SCOPE;
2244 break;
2245 case 0:
2246 break;
2247 case -1:
a2a5de95
NC
2248 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2249 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2250 }
463ee0b2 2251 }
8be1be90
AMS
2252 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2253 && type != OP_LEAVESUBLV)
2254 o->op_flags |= OPf_REF;
11343788 2255 return o;
463ee0b2
LW
2256}
2257
864dbfa3 2258STATIC bool
5f66b61c 2259S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1
PP
2260{
2261 switch (type) {
32a60974 2262 case OP_POS:
3fe9a6f1 2263 case OP_SASSIGN:
1efec5ed 2264 if (o && o->op_type == OP_RV2GV)
3fe9a6f1
PP
2265 return FALSE;
2266 /* FALL THROUGH */
2267 case OP_PREINC:
2268 case OP_PREDEC:
2269 case OP_POSTINC:
2270 case OP_POSTDEC:
2271 case OP_I_PREINC:
2272 case OP_I_PREDEC:
2273 case OP_I_POSTINC:
2274 case OP_I_POSTDEC:
2275 case OP_POW:
2276 case OP_MULTIPLY:
2277 case OP_DIVIDE:
2278 case OP_MODULO:
2279 case OP_REPEAT:
2280 case OP_ADD:
2281 case OP_SUBTRACT:
2282 case OP_I_MULTIPLY:
2283 case OP_I_DIVIDE:
2284 case OP_I_MODULO:
2285 case OP_I_ADD:
2286 case OP_I_SUBTRACT:
2287 case OP_LEFT_SHIFT:
2288 case OP_RIGHT_SHIFT:
2289 case OP_BIT_AND:
2290 case OP_BIT_XOR:
2291 case OP_BIT_OR:
2292 case OP_CONCAT:
2293 case OP_SUBST:
2294 case OP_TRANS:
bb16bae8 2295 case OP_TRANSR:
49e9fbe6
GS
2296 case OP_READ:
2297 case OP_SYSREAD:
2298 case OP_RECV:
bf4b1e52
GS
2299 case OP_ANDASSIGN:
2300 case OP_ORASSIGN:
410d09fe 2301 case OP_DORASSIGN:
3fe9a6f1
PP
2302 return TRUE;
2303 default:
2304 return FALSE;
2305 }
2306}
2307
35cd451c 2308STATIC bool
5f66b61c 2309S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2310{
7918f24d
NC
2311 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2312
35cd451c
GS
2313 switch (o->op_type) {
2314 case OP_PIPE_OP:
2315 case OP_SOCKPAIR:
504618e9 2316 if (numargs == 2)
35cd451c
GS
2317 return TRUE;
2318 /* FALL THROUGH */
2319 case OP_SYSOPEN:
2320 case OP_OPEN:
ded8aa31 2321 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
2322 case OP_SOCKET:
2323 case OP_OPEN_DIR:
2324 case OP_ACCEPT:
504618e9 2325 if (numargs == 1)
35cd451c 2326 return TRUE;
5f66b61c 2327 /* FALLTHROUGH */
35cd451c
GS
2328 default:
2329 return FALSE;
2330 }
2331}
2332
0d86688d
NC
2333static OP *
2334S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2335{
11343788 2336 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2337 OP *kid;
11343788 2338 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
2339 ref(kid, type);
2340 }
11343788 2341 return o;
463ee0b2
LW
2342}
2343
2344OP *
e4c5ccf3 2345Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2346{
27da23d5 2347 dVAR;
463ee0b2 2348 OP *kid;
463ee0b2 2349
7918f24d
NC
2350 PERL_ARGS_ASSERT_DOREF;
2351
13765c85 2352 if (!o || (PL_parser && PL_parser->error_count))
11343788 2353 return o;
463ee0b2 2354
11343788 2355 switch (o->op_type) {
a0d0e21e 2356 case OP_ENTERSUB:
f4df43b5 2357 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB
2358 !(o->op_flags & OPf_STACKED)) {
2359 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2360 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2361 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2362 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2363 o->op_flags |= OPf_SPECIAL;
e26df76a 2364 o->op_private &= ~1;
8990e307 2365 }
767eda44 2366 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG
2367 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2368 : type == OP_RV2HV ? OPpDEREF_HV
2369 : OPpDEREF_SV);
767eda44
FC
2370 o->op_flags |= OPf_MOD;
2371 }
2372
8990e307 2373 break;
aeea060c 2374
463ee0b2 2375 case OP_COND_EXPR:
11343788 2376 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2377 doref(kid, type, set_op_ref);
463ee0b2 2378 break;
8990e307 2379 case OP_RV2SV:
35cd451c
GS
2380 if (type == OP_DEFINED)
2381 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2382 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW
2383 /* FALL THROUGH */
2384 case OP_PADSV:
5f05dabc 2385 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
2386 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2387 : type == OP_RV2HV ? OPpDEREF_HV
2388 : OPpDEREF_SV);
11343788 2389 o->op_flags |= OPf_MOD;
a0d0e21e 2390 }
8990e307 2391 break;
1c846c1f 2392
463ee0b2
LW
2393 case OP_RV2AV:
2394 case OP_RV2HV:
e4c5ccf3
RH
2395 if (set_op_ref)
2396 o->op_flags |= OPf_REF;
8990e307 2397 /* FALL THROUGH */
463ee0b2 2398 case OP_RV2GV:
35cd451c
GS
2399 if (type == OP_DEFINED)
2400 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2401 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2402 break;
8990e307 2403
463ee0b2
LW
2404 case OP_PADAV:
2405 case OP_PADHV:
e4c5ccf3
RH
2406 if (set_op_ref)
2407 o->op_flags |= OPf_REF;
79072805 2408 break;
aeea060c 2409
8990e307 2410 case OP_SCALAR:
79072805 2411 case OP_NULL:
518618af 2412 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 2413 break;
e4c5ccf3 2414 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW
2415 break;
2416 case OP_AELEM:
2417 case OP_HELEM:
e4c5ccf3 2418 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2419 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
2420 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2421 : type == OP_RV2HV ? OPpDEREF_HV
2422 : OPpDEREF_SV);
11343788 2423 o->op_flags |= OPf_MOD;
8990e307 2424 }
79072805
LW
2425 break;
2426
463ee0b2 2427 case OP_SCOPE:
79072805 2428 case OP_LEAVE:
e4c5ccf3
RH
2429 set_op_ref = FALSE;
2430 /* FALL THROUGH */
79072805 2431 case OP_ENTER:
8990e307 2432 case OP_LIST:
11343788 2433 if (!(o->op_flags & OPf_KIDS))
79072805 2434 break;
e4c5ccf3 2435 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2436 break;
a0d0e21e
LW
2437 default:
2438 break;
79072805 2439 }
11343788 2440 return scalar(o);
8990e307 2441
79072805
LW
2442}
2443
09bef843
SB
2444STATIC OP *
2445S_dup_attrlist(pTHX_ OP *o)
2446{
97aff369 2447 dVAR;
0bd48802 2448 OP *rop;
09bef843 2449
7918f24d
NC
2450 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2451
09bef843
SB
2452 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2453 * where the first kid is OP_PUSHMARK and the remaining ones
2454 * are OP_CONST. We need to push the OP_CONST values.
2455 */
2456 if (o->op_type == OP_CONST)
b37c2d43 2457 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC
2458#ifdef PERL_MAD
2459 else if (o->op_type == OP_NULL)
1d866c12 2460 rop = NULL;
eb8433b7 2461#endif
09bef843
SB
2462 else {
2463 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2464 rop = NULL;
09bef843
SB
2465 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2466 if (o->op_type == OP_CONST)
2fcb4757 2467 rop = op_append_elem(OP_LIST, rop,
09bef843 2468 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2469 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB
2470 }
2471 }
2472 return rop;
2473}
2474
2475STATIC void
ad0dc73b 2476S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 2477{
27da23d5 2478 dVAR;
ad0dc73b 2479 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
09bef843 2480
7918f24d
NC
2481 PERL_ARGS_ASSERT_APPLY_ATTRS;
2482
09bef843
SB
2483 /* fake up C<use attributes $pkg,$rv,@attrs> */
2484 ENTER; /* need to protect against side-effects of 'use' */
e4783991 2485
09bef843 2486#define ATTRSMODULE "attributes"
95f0a2f1
SB
2487#define ATTRSMODULE_PM "attributes.pm"
2488
ad0dc73b 2489 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL
2490 newSVpvs(ATTRSMODULE),
2491 NULL,
2fcb4757 2492 op_prepend_elem(OP_LIST,
95f0a2f1 2493 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2494 op_prepend_elem(OP_LIST,
95f0a2f1
SB
2495 newSVOP(OP_CONST, 0,
2496 newRV(target)),
2497 dup_attrlist(attrs))));
09bef843
SB
2498 LEAVE;
2499}
2500
95f0a2f1
SB
2501STATIC void
2502S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2503{
97aff369 2504 dVAR;
95f0a2f1 2505 OP *pack, *imop, *arg;
ad0dc73b 2506 SV *meth, *stashsv, **svp;
95f0a2f1 2507
7918f24d
NC
2508 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2509
95f0a2f1
SB
2510 if (!attrs)
2511 return;
2512
2513 assert(target->op_type == OP_PADSV ||
2514 target->op_type == OP_PADHV ||
2515 target->op_type == OP_PADAV);
2516
2517 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC
2518 ENTER; /* need to protect against side-effects of 'use' */
2519 /* Don't force the C<use> if we don't need it. */
2520 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2521 if (svp && *svp != &PL_sv_undef)
2522 NOOP; /* already in %INC */
2523 else
2524 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2525 newSVpvs(ATTRSMODULE), NULL);
2526 LEAVE;
95f0a2f1
SB
2527
2528 /* Need package name for method call. */
6136c704 2529 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB
2530
2531 /* Build up the real arg-list. */
5aaec2b4
NC
2532 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2533
95f0a2f1
SB
2534 arg = newOP(OP_PADSV, 0);
2535 arg->op_targ = target->op_targ;
2fcb4757 2536 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2537 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2538 op_prepend_elem(OP_LIST,
95f0a2f1 2539 newUNOP(OP_REFGEN, 0,
3ad73efd 2540 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB
2541 dup_attrlist(attrs)));
2542
2543 /* Fake up a method call to import */
18916d0d 2544 meth = newSVpvs_share("import");
95f0a2f1 2545 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z
2546 op_append_elem(OP_LIST,
2547 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2548 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB
2549
2550 /* Combine the ops. */
2fcb4757 2551 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB
2552}
2553
2554/*
2555=notfor apidoc apply_attrs_string
2556
2557Attempts to apply a list of attributes specified by the C<attrstr> and
2558C<len> arguments to the subroutine identified by the C<cv> argument which
2559is expected to be associated with the package identified by the C<stashpv>
2560argument (see L<attributes>). It gets this wrong, though, in that it
2561does not correctly identify the boundaries of the individual attribute
2562specifications within C<attrstr>. This is not really intended for the
2563public API, but has to be listed here for systems such as AIX which
2564need an explicit export list for symbols. (It's called from XS code
2565in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2566to respect attribute syntax properly would be welcome.
2567
2568=cut
2569*/
2570
be3174d2 2571void
6867be6d
AL
2572Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2573 const char *attrstr, STRLEN len)
be3174d2 2574{
5f66b61c 2575 OP *attrs = NULL;
be3174d2 2576
7918f24d
NC
2577 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2578
be3174d2
GS
2579 if (!len) {
2580 len = strlen(attrstr);
2581 }
2582
2583 while (len) {
2584 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2585 if (len) {
890ce7af 2586 const char * const sstr = attrstr;
be3174d2 2587 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2588 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS
2589 newSVOP(OP_CONST, 0,
2590 newSVpvn(sstr, attrstr-sstr)));
2591 }
2592 }
2593
2594 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2595 newSVpvs(ATTRSMODULE),
2fcb4757 2596 NULL, op_prepend_elem(OP_LIST,
be3174d2 2597 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2598 op_prepend_elem(OP_LIST,
be3174d2 2599 newSVOP(OP_CONST, 0,
ad64d0ec 2600 newRV(MUTABLE_SV(cv))),
be3174d2
GS
2601 attrs)));
2602}
2603
09bef843 2604STATIC OP *
95f0a2f1 2605S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2606{
97aff369 2607 dVAR;
93a17b20 2608 I32 type;
a1fba7eb 2609 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2610
7918f24d
NC
2611 PERL_ARGS_ASSERT_MY_KID;
2612
13765c85 2613 if (!o || (PL_parser && PL_parser->error_count))
11343788 2614 return o;
93a17b20 2615
bc61e325 2616 type = o->op_type;
eb8433b7
NC
2617 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2618 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2619 return o;
2620 }
2621
93a17b20 2622 if (type == OP_LIST) {
6867be6d 2623 OP *kid;
11343788 2624 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2625 my_kid(kid, attrs, imopsp);
0865059d 2626 return o;
8b8c1fb9 2627 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 2628 return o;
77ca0c92
LW
2629 } else if (type == OP_RV2SV || /* "our" declaration */
2630 type == OP_RV2AV ||
2631 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2632 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2633 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2634 OP_DESC(o),
12bd6ede
DM
2635 PL_parser->in_my == KEY_our
2636 ? "our"
2637 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2638 } else if (attrs) {
551405c4 2639 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM
2640 PL_parser->in_my = FALSE;
2641 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS
2642 apply_attrs(GvSTASH(gv),
2643 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC
2644 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2645 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
ad0dc73b 2646 attrs);
1ce0b88c 2647 }
192587c2 2648 o->op_private |= OPpOUR_INTRO;
77ca0c92 2649 return o;
95f0a2f1
SB
2650 }
2651 else if (type != OP_PADSV &&
93a17b20
LW
2652 type != OP_PADAV &&
2653 type != OP_PADHV &&
2654 type != OP_PUSHMARK)
2655 {
eb64745e 2656 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2657 OP_DESC(o),
12bd6ede
DM
2658 PL_parser->in_my == KEY_our
2659 ? "our"
2660 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2661 return o;
93a17b20 2662 }
09bef843
SB
2663 else if (attrs && type != OP_PUSHMARK) {
2664 HV *stash;
09bef843 2665
12bd6ede
DM
2666 PL_parser->in_my = FALSE;
2667 PL_parser->in_my_stash = NULL;
eb64745e 2668
09bef843 2669 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM
2670 stash = PAD_COMPNAME_TYPE(o->op_targ);
2671 if (!stash)
09bef843 2672 stash = PL_curstash;
95f0a2f1 2673 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2674 }
11343788
MB
2675 o->op_flags |= OPf_MOD;
2676 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2677 if (stately)
952306ac 2678 o->op_private |= OPpPAD_STATE;
11343788 2679 return o;
93a17b20
LW
2680}
2681
2682OP *
09bef843
SB
2683Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2684{
97aff369 2685 dVAR;
0bd48802 2686 OP *rops;
95f0a2f1
SB
2687 int maybe_scalar = 0;
2688
7918f24d
NC
2689 PERL_ARGS_ASSERT_MY_ATTRS;
2690
d2be0de5 2691/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2692 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2693#if 0
09bef843
SB
2694 if (o->op_flags & OPf_PARENS)
2695 list(o);
95f0a2f1
SB
2696 else
2697 maybe_scalar = 1;
d2be0de5
YST
2698#else
2699 maybe_scalar = 1;
2700#endif
09bef843
SB
2701 if (attrs)
2702 SAVEFREEOP(attrs);
5f66b61c 2703 rops = NULL;
95f0a2f1
SB
2704 o = my_kid(o, attrs, &rops);
2705 if (rops) {
2706 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2707 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB
2708 o->op_private |= OPpLVAL_INTRO;
2709 }
f5d1ed10
FC
2710 else {
2711 /* The listop in rops might have a pushmark at the beginning,
2712 which will mess up list assignment. */
2713 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2714 if (rops->op_type == OP_LIST &&
2715 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2716 {
2717 OP * const pushmark = lrops->op_first;
2718 lrops->op_first = pushmark->op_sibling;
2719 op_free(pushmark);
2720 }
2fcb4757 2721 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2722 }
95f0a2f1 2723 }
12bd6ede
DM
2724 PL_parser->in_my = FALSE;
2725 PL_parser->in_my_stash = NULL;
eb64745e 2726 return o;
09bef843
SB
2727}
2728
2729OP *
864dbfa3 2730Perl_sawparens(pTHX_ OP *o)
79072805 2731{
96a5add6 2732 PERL_UNUSED_CONTEXT;
79072805
LW
2733 if (o)
2734 o->op_flags |= OPf_PARENS;
2735 return o;
2736}
2737
2738OP *
864dbfa3 2739Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2740{
11343788 2741 OP *o;
59f00321 2742 bool ismatchop = 0;
1496a290
AL
2743 const OPCODE ltype = left->op_type;
2744 const OPCODE rtype = right->op_type;
79072805 2745
7918f24d
NC
2746 PERL_ARGS_ASSERT_BIND_MATCH;
2747
1496a290
AL
2748 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2749 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2750 {
1496a290 2751 const char * const desc
bb16bae8
FC
2752 = PL_op_desc[(
2753 rtype == OP_SUBST || rtype == OP_TRANS
2754 || rtype == OP_TRANSR
2755 )
666ea192 2756 ? (int)rtype : OP_MATCH];
c6771ab6
FC
2757 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2758 GV *gv;
2759 SV * const name =
2760 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2761 ? cUNOPx(left)->op_first->op_type == OP_GV
2762 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2763 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2764 : NULL
ba510004
FC
2765 : varname(
2766 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2767 );
c6771ab6
FC
2768 if (name)
2769 Perl_warner(aTHX_ packWARN(WARN_MISC),
2770 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2771 desc, name, name);
2772 else {
2773 const char * const sample = (isary
666ea192 2774 ? "@array" : "%hash");
c6771ab6 2775 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2776 "Applying %s to %s will act on scalar(%s)",
599cee73 2777 desc, sample, sample);
c6771ab6 2778 }
2ae324a7
PP
2779 }
2780
1496a290 2781 if (rtype == OP_CONST &&
5cc9e5c9
RH
2782 cSVOPx(right)->op_private & OPpCONST_BARE &&
2783 cSVOPx(right)->op_private & OPpCONST_STRICT)
2784 {
2785 no_bareword_allowed(right);
2786 }
2787
bb16bae8 2788 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC
2789 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2790 type == OP_NOT)
2791 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC
2792 if (rtype == OP_TRANSR && type == OP_NOT)
2793 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2794
2474a784
FC
2795 ismatchop = (rtype == OP_MATCH ||
2796 rtype == OP_SUBST ||
bb16bae8 2797 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2798 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS
2799 if (ismatchop && right->op_private & OPpTARGET_MY) {
2800 right->op_targ = 0;
2801 right->op_private &= ~OPpTARGET_MY;
2802 }
2803 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL
2804 OP *newleft;
2805
79072805 2806 right->op_flags |= OPf_STACKED;
bb16bae8 2807 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2808 ! (rtype == OP_TRANS &&
4f4d7508
DC
2809 right->op_private & OPpTRANS_IDENTICAL) &&
2810 ! (rtype == OP_SUBST &&
2811 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2812 newleft = op_lvalue(left, rtype);
1496a290
AL
2813 else
2814 newleft = left;
bb16bae8 2815 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2816 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2817 else
2fcb4757 2818 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2819 if (type == OP_NOT)
11343788
MB
2820 return newUNOP(OP_NOT, 0, scalar(o));
2821 return o;
79072805
LW
2822 }
2823 else
2824 return bind_match(type, left,
d63c20f2 2825 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW
2826}
2827
2828OP *
864dbfa3 2829Perl_invert(pTHX_ OP *o)
79072805 2830{
11343788 2831 if (!o)
1d866c12 2832 return NULL;
11343788 2833 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
2834}
2835
3ad73efd
Z
2836/*
2837=for apidoc Amx|OP *|op_scope|OP *o
2838
2839Wraps up an op tree with some additional ops so that at runtime a dynamic
2840scope will be created. The original ops run in the new dynamic scope,
2841and then, provided that they exit normally, the scope will be unwound.
2842The additional ops used to create and unwind the dynamic scope will
2843normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2844instead if the ops are simple enough to not need the full dynamic scope
2845structure.
2846
2847=cut
2848*/
2849
79072805 2850OP *
3ad73efd 2851Perl_op_scope(pTHX_ OP *o)
79072805 2852{
27da23d5 2853 dVAR;
79072805 2854 if (o) {
284167a5 2855 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2fcb4757 2856 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2857 o->op_type = OP_LEAVE;
22c35a8c 2858 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2859 }
fdb22418
HS
2860 else if (o->op_type == OP_LINESEQ) {
2861 OP *kid;
2862 o->op_type = OP_SCOPE;
2863 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2864 kid = ((LISTOP*)o)->op_first;
59110972 2865 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2866 op_null(kid);
59110972
RH
2867
2868 /* The following deals with things like 'do {1 for 1}' */
2869 kid = kid->op_sibling;
2870 if (kid &&
2871 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2872 op_null(kid);
2873 }
463ee0b2 2874 }
fdb22418 2875 else
5f66b61c 2876 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW
2877 }
2878 return o;
2879}
1930840b 2880
705fe0e5
FC
2881OP *
2882Perl_op_unscope(pTHX_ OP *o)
2883{
2884 if (o && o->op_type == OP_LINESEQ) {
2885 OP *kid = cLISTOPo->op_first;
2886 for(; kid; kid = kid->op_sibling)
2887 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2888 op_null(kid);
2889 }
2890 return o;
2891}
2892
a0d0e21e 2893int
864dbfa3 2894Perl_block_start(pTHX_ int full)
79072805 2895{
97aff369 2896 dVAR;
73d840c0 2897 const int retval = PL_savestack_ix;
1930840b 2898
dd2155a4 2899 pad_block_start(full);
b3ac6de7 2900 SAVEHINTS();
3280af22 2901 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2902 SAVECOMPILEWARNINGS();
72dc9ed5 2903 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2904
a88d97bf 2905 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2906
a0d0e21e
LW
2907 return retval;
2908}
2909
2910OP*
864dbfa3 2911Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2912{
97aff369 2913 dVAR;
6867be6d 2914 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b 2915 OP* retval = scalarseq(seq);
6d5c2147 2916 OP *o;
1930840b 2917
a88d97bf 2918 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2919
e9818f4e 2920 LEAVE_SCOPE(floor);
623e6609 2921 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2922 if (needblockscope)
3280af22 2923 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
6d5c2147
FC
2924 o = pad_leavemy();
2925
2926 if (o) {
2927 /* pad_leavemy has created a sequence of introcv ops for all my
2928 subs declared in the block. We have to replicate that list with
2929 clonecv ops, to deal with this situation:
2930
2931 sub {
2932 my sub s1;
2933 my sub s2;
2934 sub s1 { state sub foo { \&s2 } }
2935 }->()
2936
2937 Originally, I was going to have introcv clone the CV and turn
2938 off the stale flag. Since &s1 is declared before &s2, the
2939 introcv op for &s1 is executed (on sub entry) before the one for
2940 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
2941 cloned, since it is a state sub) closes over &s2 and expects
2942 to see it in its outer CV’s pad. If the introcv op clones &s1,
2943 then &s2 is still marked stale. Since &s1 is not active, and
2944 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
2945 ble will not stay shared’ warning. Because it is the same stub
2946 that will be used when the introcv op for &s2 is executed, clos-
2947 ing over it is safe. Hence, we have to turn off the stale flag
2948 on all lexical subs in the block before we clone any of them.
2949 Hence, having introcv clone the sub cannot work. So we create a
2950 list of ops like this:
2951
2952 lineseq
2953 |
2954 +-- introcv
2955 |
2956 +-- introcv
2957 |
2958 +-- introcv
2959 |
2960 .
2961 .
2962 .
2963 |
2964 +-- clonecv
2965 |
2966 +-- clonecv
2967 |
2968 +-- clonecv
2969 |
2970 .
2971 .
2972 .
2973 */
2974 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
2975 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
2976 for (;; kid = kid->op_sibling) {
2977 OP *newkid = newOP(OP_CLONECV, 0);
2978 newkid->op_targ = kid->op_targ;
2979 o = op_append_elem(OP_LINESEQ, o, newkid);
2980 if (kid == last) break;
2981 }
2982 retval = op_prepend_elem(OP_LINESEQ, o, retval);
2983 }
1930840b 2984
a88d97bf 2985 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2986
a0d0e21e
LW
2987 return retval;
2988}
2989
fd85fad2
BM
2990/*
2991=head1 Compile-time scope hooks
2992
3e4ddde5 2993=for apidoc Aox||blockhook_register
fd85fad2
BM
2994
2995Register a set of hooks to be called when the Perl lexical scope changes
2996at compile time. See L<perlguts/"Compile-time scope hooks">.
2997
2998=cut
2999*/
3000
bb6c22e7
BM
3001void
3002Perl_blockhook_register(pTHX_ BHK *hk)
3003{
3004 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3005
3006 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3007}
3008
76e3520e 3009STATIC OP *
cea2e8a9 3010S_newDEFSVOP(pTHX)
54b9620d 3011{
97aff369 3012 dVAR;
cc76b5cc 3013 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 3014 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS
3015 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3016 }
3017 else {
551405c4 3018 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS
3019 o->op_targ = offset;
3020 return o;
3021 }
54b9620d
MB
3022}
3023
a0d0e21e 3024void
864dbfa3 3025Perl_newPROG(pTHX_ OP *o)
a0d0e21e 3026{
97aff369 3027 dVAR;
7918f24d
NC
3028
3029 PERL_ARGS_ASSERT_NEWPROG;
3030
3280af22 3031 if (PL_in_eval) {
86a64801 3032 PERL_CONTEXT *cx;
63429d50 3033 I32 i;
b295d113
TH
3034 if (PL_eval_root)
3035 return;
faef0170
HS
3036 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3037 ((PL_in_eval & EVAL_KEEPERR)
3038 ? OPf_SPECIAL : 0), o);
86a64801
GG
3039
3040 cx = &cxstack[cxstack_ix];
3041 assert(CxTYPE(cx) == CXt_EVAL);
3042
3043 if ((cx->blk_gimme & G_WANT) == G_VOID)
3044 scalarvoid(PL_eval_root);
3045 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3046 list(PL_eval_root);
3047 else
3048 scalar(PL_eval_root);
3049
5983a79d 3050 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS
3051 PL_eval_root->op_private |= OPpREFCOUNTED;
3052 OpREFCNT_set(PL_eval_root, 1);
3280af22 3053 PL_eval_root->op_next = 0;
63429d50
FC
3054 i = PL_savestack_ix;
3055 SAVEFREEOP(o);
3056 ENTER;
a2efc822 3057 CALL_PEEP(PL_eval_start);
86a64801 3058 finalize_optree(PL_eval_root);
63429d50
FC
3059 LEAVE;
3060 PL_savestack_ix = i;
a0d0e21e
LW
3061 }
3062 else {
6be89cf9 3063 if (o->op_type == OP_STUB) {
22e660b4
NC
3064 /* This block is entered if nothing is compiled for the main
3065 program. This will be the case for an genuinely empty main
3066 program, or one which only has BEGIN blocks etc, so already
3067 run and freed.
3068
3069 Historically (5.000) the guard above was !o. However, commit
3070 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3071 c71fccf11fde0068, changed perly.y so that newPROG() is now
3072 called with the output of block_end(), which returns a new
3073 OP_STUB for the case of an empty optree. ByteLoader (and
3074 maybe other things) also take this path, because they set up
3075 PL_main_start and PL_main_root directly, without generating an
3076 optree.
8b31d4e4
NC
3077
3078 If the parsing the main program aborts (due to parse errors,
3079 or due to BEGIN or similar calling exit), then newPROG()
3080 isn't even called, and hence this code path and its cleanups
3081 are skipped. This shouldn't make a make a difference:
3082 * a non-zero return from perl_parse is a failure, and
3083 perl_destruct() should be called immediately.
3084 * however, if exit(0) is called during the parse, then
3085 perl_parse() returns 0, and perl_run() is called. As
3086 PL_main_start will be NULL, perl_run() will return
3087 promptly, and the exit code will remain 0.
22e660b4
NC
3088 */
3089
6be89cf9
AE
3090 PL_comppad_name = 0;
3091 PL_compcv = 0;
d2c837a0 3092 S_op_destroy(aTHX_ o);
a0d0e21e 3093 return;
6be89cf9 3094 }
3ad73efd 3095 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS
3096 PL_curcop = &PL_compiling;
3097 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
3098 PL_main_root->op_private |= OPpREFCOUNTED;
3099 OpREFCNT_set(PL_main_root, 1);
3280af22 3100 PL_main_root->op_next = 0;
a2efc822 3101 CALL_PEEP(PL_main_start);
d164302a 3102 finalize_optree(PL_main_root);
8be227ab 3103 cv_forget_slab(PL_compcv);
3280af22 3104 PL_compcv = 0;
3841441e 3105
4fdae800 3106 /* Register with debugger */
84902520 3107 if (PERLDB_INTER) {
b96d8cd9 3108 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS
3109 if (cv) {
3110 dSP;
924508f0 3111 PUSHMARK(SP);
ad64d0ec 3112 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 3113 PUTBACK;
ad64d0ec 3114 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS
3115 }
3116 }
79072805 3117 }
79072805
LW
3118}
3119
3120OP *
864dbfa3 3121Perl_localize(pTHX_ OP *o, I32 lex)
79072805 3122{
97aff369 3123 dVAR;
7918f24d
NC
3124
3125 PERL_ARGS_ASSERT_LOCALIZE;
3126
79072805 3127 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
3128/* [perl #17376]: this appears to be premature, and results in code such as
3129 C< our(%x); > executing in list mode rather than void mode */
3130#if 0
79072805 3131 list(o);
d2be0de5 3132#else
6f207bd3 3133 NOOP;
d2be0de5 3134#endif
8990e307 3135 else {
f06b5848
DM
3136 if ( PL_parser->bufptr > PL_parser->oldbufptr
3137 && PL_parser->bufptr[-1] == ','
041457d9 3138 && ckWARN(WARN_PARENTHESIS))
64420d0d 3139 {
f06b5848 3140 char *s = PL_parser->bufptr;
bac662ee 3141 bool sigil = FALSE;
64420d0d 3142
8473848f 3143 /* some heuristics to detect a potential error */
bac662ee 3144 while (*s && (strchr(", \t\n", *s)))
64420d0d 3145 s++;
8473848f 3146
bac662ee
ST
3147 while (1) {
3148 if (*s && strchr("@$%*", *s) && *++s
0eb30aeb 3149 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
bac662ee
ST
3150 s++;
3151 sigil = TRUE;
0eb30aeb 3152 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
bac662ee
ST
3153 s++;
3154 while (*s && (strchr(", \t\n", *s)))
3155 s++;
3156 }
3157 else
3158 break;
3159 }
3160 if (sigil && (*s == ';' || *s == '=')) {
3161 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 3162 "Parentheses missing around \"%s\" list",
12bd6ede
DM
3163 lex
3164 ? (PL_parser->in_my == KEY_our
3165 ? "our"
3166 : PL_parser->in_my == KEY_state
3167 ? "state"
3168 : "my")
3169 : "local");
8473848f 3170 }
8990e307
LW
3171 }
3172 }
93a17b20 3173 if (lex)
eb64745e 3174 o = my(o);
93a17b20 3175 else
3ad73efd 3176 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM
3177 PL_parser->in_my = FALSE;
3178 PL_parser->in_my_stash = NULL;
eb64745e 3179 return o;
79072805
LW
3180}
3181
3182OP *
864dbfa3 3183Perl_jmaybe(pTHX_ OP *o)
79072805 3184{
7918f24d
NC
3185 PERL_ARGS_ASSERT_JMAYBE;
3186
79072805 3187 if (o->op_type == OP_LIST) {
fafc274c 3188 OP * const o2
d4c19fe8 3189 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 3190 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW
3191 }
3192 return o;
3193}
3194
985b9e54
GG
3195PERL_STATIC_INLINE OP *
3196S_op_std_init(pTHX_ OP *o)
3197{
3198 I32 type = o->op_type;
3199
3200 PERL_ARGS_ASSERT_OP_STD_INIT;
3201
3202 if (PL_opargs[type] & OA_RETSCALAR)
3203 scalar(o);
3204 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3205 o->op_targ = pad_alloc(type, SVs_PADTMP);
3206
3207 return o;
3208}
3209
3210PERL_STATIC_INLINE OP *
3211S_op_integerize(pTHX_ OP *o)
3212{
3213 I32 type = o->op_type;
3214
3215 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3216
077da62f
FC
3217 /* integerize op. */
3218 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
985b9e54 3219 {
f5f19483 3220 dVAR;
985b9e54
GG
3221 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3222 }
3223
3224 if (type == OP_NEGATE)
3225 /* XXX might want a ck_negate() for this */
3226 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3227
3228 return o;
3229}
3230
1f676739 3231static OP *
5aaab254 3232S_fold_constants(pTHX_ OP *o)
79072805 3233{
27da23d5 3234 dVAR;
eb578fdb 3235 OP * VOL curop;
eb8433b7 3236 OP *newop;
8ea43dc8 3237 VOL I32 type = o->op_type;
e3cbe32f 3238 SV * VOL sv = NULL;
b7f7fd0b
NC
3239 int ret = 0;
3240 I32 oldscope;
3241 OP *old_next;
5f2d9966
DM
3242 SV * const oldwarnhook = PL_warnhook;
3243 SV * const olddiehook = PL_diehook;
c427f4d2 3244 COP not_compiling;
b7f7fd0b 3245 dJMPENV;
79072805 3246
7918f24d
NC
3247 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3248
22c35a8c 3249 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
3250 goto nope;
3251
de939608 3252 switch (type) {
de939608
CS
3253 case OP_UCFIRST:
3254 case OP_LCFIRST:
3255 case OP_UC:
3256 case OP_LC:
7ccde120 3257 case OP_FC:
69dcf70c
MB
3258 case OP_SLT:
3259 case OP_SGT:
3260 case OP_SLE:
3261 case OP_SGE:
3262 case OP_SCMP:
b3fd6149 3263 case OP_SPRINTF:
2de3dbcc 3264 /* XXX what about the numeric ops? */
82ad65bb 3265 if (IN_LOCALE_COMPILETIME)
de939608 3266 goto nope;
553e7bb0 3267 break;
dd9a6ccf
FC
3268 case OP_PACK:
3269 if (!cLISTOPo->op_first->op_sibling
3270 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3271 goto nope;
3272 {
3273 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3274 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3275 {
3276 const char *s = SvPVX_const(sv);
3277 while (s < SvEND(sv)) {
3278 if (*s == 'p' || *s == 'P') goto nope;
3279 s++;
3280 }
3281 }
3282 }
3283 break;
baed7faa
FC
3284 case OP_REPEAT:
3285 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
de939608
CS
3286 }
3287
13765c85 3288 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
3289 goto nope; /* Don't try to run w/ errors */
3290
79072805 3291 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL
3292 const OPCODE type = curop->op_type;
3293 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3294 type != OP_LIST &&
3295 type != OP_SCALAR &&
3296 type != OP_NULL &&
3297 type != OP_PUSHMARK)
7a52d87a 3298 {
79072805
LW
3299 goto nope;
3300 }
3301 }
3302
3303 curop = LINKLIST(o);
b7f7fd0b 3304 old_next = o->op_next;
79072805 3305 o->op_next = 0;
533c011a 3306 PL_op = curop;
b7f7fd0b
NC
3307
3308 oldscope = PL_scopestack_ix;
edb2152a 3309 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3310
c427f4d2
NC
3311 /* Verify that we don't need to save it: */
3312 assert(PL_curcop == &PL_compiling);
3313 StructCopy(&PL_compiling, &not_compiling, COP);
3314 PL_curcop = &not_compiling;
3315 /* The above ensures that we run with all the correct hints of the
3316 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3317 assert(IN_PERL_RUNTIME);
5f2d9966
DM
3318 PL_warnhook = PERL_WARNHOOK_FATAL;
3319 PL_diehook = NULL;
b7f7fd0b
NC
3320 JMPENV_PUSH(ret);
3321
3322 switch (ret) {
3323 case 0:
3324 CALLRUNOPS(aTHX);
3325 sv = *(PL_stack_sp--);
523a0f0c
NC
3326 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3327#ifdef PERL_MAD
3328 /* Can't simply swipe the SV from the pad, because that relies on
3329 the op being freed "real soon now". Under MAD, this doesn't
3330 happen (see the #ifdef below). */
3331 sv = newSVsv(sv);
3332#else
b7f7fd0b 3333 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC
3334#endif
3335 }
b7f7fd0b
NC
3336 else if (SvTEMP(sv)) { /* grab mortal temp? */
3337 SvREFCNT_inc_simple_void(sv);
3338 SvTEMP_off(sv);
3339 }
3340 break;
3341 case 3:
3342 /* Something tried to die. Abandon constant folding. */
3343 /* Pretend the error never happened. */
ab69dbc2 3344 CLEAR_ERRSV();
b7f7fd0b
NC
3345 o->op_next = old_next;
3346 break;
3347 default:
3348 JMPENV_POP;
5f2d9966
DM
3349 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3350 PL_warnhook = oldwarnhook;
3351 PL_diehook = olddiehook;
3352 /* XXX note that this croak may fail as we've already blown away
3353 * the stack - eg any nested evals */
b7f7fd0b
NC
3354 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3355 }
b7f7fd0b 3356 JMPENV_POP;
5f2d9966
DM
3357 PL_warnhook = oldwarnhook;
3358 PL_diehook = olddiehook;
c427f4d2 3359 PL_curcop = &PL_compiling;
edb2152a
NC
3360
3361 if (PL_scopestack_ix > oldscope)
3362 delete_eval_scope();
eb8433b7 3363
b7f7fd0b
NC
3364 if (ret)
3365 goto nope;
3366
eb8433b7 3367#ifndef PERL_MAD
79072805 3368 op_free(o);
eb8433b7 3369#endif
de5e01c2 3370 assert(sv);
79072805 3371 if (type == OP_RV2GV)
159b6efe 3372 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3373 else
cc2ebcd7 3374 newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
eb8433b7
NC
3375 op_getmad(o,newop,'f');
3376 return newop;
aeea060c 3377
b7f7fd0b 3378 nope:
79072805
LW
3379 return o;
3380}
3381
1f676739 3382static OP *
5aaab254 3383S_gen_constant_list(pTHX_ OP *o)
79072805 3384{
27da23d5 3385 dVAR;
eb578fdb 3386 OP *curop;
6867be6d 3387 const I32 oldtmps_floor = PL_tmps_floor;
79072805 3388
a0d0e21e 3389 list(o);
13765c85 3390 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
3391 return o; /* Don't attempt to run with errors */
3392
533c011a 3393 PL_op = curop = LINKLIST(o);
a0d0e21e 3394 o->op_next = 0;
a2efc822 3395 CALL_PEEP(curop);
897d3989 3396 Perl_pp_pushmark(aTHX);
cea2e8a9 3397 CALLRUNOPS(aTHX);
533c011a 3398 PL_op = curop;
78c72037
NC
3399 assert (!(curop->op_flags & OPf_SPECIAL));
3400 assert(curop->op_type == OP_RANGE);
897d3989 3401 Perl_pp_anonlist(aTHX);
3280af22 3402 PL_tmps_floor = oldtmps_floor;
79072805
LW
3403
3404 o->op_type = OP_RV2AV;
22c35a8c 3405 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG
3406 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3407 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3408 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3409 curop = ((UNOP*)o)->op_first;
b37c2d43 3410 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC
3411#ifdef PERL_MAD
3412 op_getmad(curop,o,'O');
3413#else
79072805 3414 op_free(curop);
eb8433b7 3415#endif
5983a79d 3416 LINKLIST(o);
79072805
LW
3417 return list(o);
3418}
3419
3420OP *
864dbfa3 3421Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3422{
27da23d5 3423 dVAR;
d67594ff 3424 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3425 if (!o || o->op_type != OP_LIST)
5f66b61c 3426 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3427 else
5dc0d613 3428 o->op_flags &= ~OPf_WANT;
79072805 3429
22c35a8c 3430 if (!(PL_opargs[type] & OA_MARK))
93c66552 3431 op_null(cLISTOPo->op_first);
bf0571fd
FC
3432 else {
3433 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3434 if (kid2 && kid2->op_type == OP_COREARGS) {
3435 op_null(cLISTOPo->op_first);
3436 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3437 }
3438 }
8990e307 3439
eb160463 3440 o->op_type = (OPCODE)type;
22c35a8c 3441 o->op_ppaddr = PL_ppaddr[type];
11343788 3442 o->op_flags |= flags;
79072805 3443
11343788 3444 o = CHECKOP(type, o);
fe2774ed 3445 if (o->op_type != (unsigned)type)
11343788 3446 return o;
79072805 3447
985b9e54 3448 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW
3449}
3450
2fcb4757
Z
3451/*
3452=head1 Optree Manipulation Functions
3453*/
3454
79072805
LW
3455/* List constructors */
3456
2fcb4757
Z
3457/*
3458=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3459
3460Append an item to the list of ops contained directly within a list-type
3461op, returning the lengthened list. I<first> is the list-type op,
3462and I<last> is the op to append to the list. I<optype> specifies the
3463intended opcode for the list. If I<first> is not already a list of the
3464right type, it will be upgraded into one. If either I<first> or I<last>
3465is null, the other is returned unchanged.
3466
3467=cut
3468*/
3469
79072805 3470OP *
2fcb4757 3471Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3472{
3473 if (!first)
3474 return last;
8990e307
LW
3475
3476 if (!last)
79072805 3477 return first;
8990e307 3478
fe2774ed 3479 if (first->op_type != (unsigned)type
155aba94
GS
3480 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3481 {
3482 return newLISTOP(type, 0, first, last);
3483 }
79072805 3484
a0d0e21e
LW
3485 if (first->op_flags & OPf_KIDS)
3486 ((LISTOP*)first)->op_last->op_sibling = last;
3487 else {
3488 first->op_flags |= OPf_KIDS;
3489 ((LISTOP*)first)->op_first = last;
3490 }
3491 ((LISTOP*)first)->op_last = last;
a0d0e21e 3492 return first;
79072805
LW
3493}
3494
2fcb4757
Z
3495/*
3496=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3497
3498Concatenate the lists of ops contained directly within two list-type ops,
3499returning the combined list. I<first> and I<last> are the list-type ops
3500to concatenate. I<optype> specifies the intended opcode for the list.
3501If either I<first> or I<last> is not already a list of the right type,
3502it will be upgraded into one. If either I<first> or I<last> is null,
3503the other is returned unchanged.
3504
3505=cut
3506*/
3507
79072805 3508OP *
2fcb4757 3509Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3510{
3511 if (!first)
2fcb4757 3512 return last;
8990e307
LW
3513
3514 if (!last)
2fcb4757 3515 return first;
8990e307 3516
fe2774ed 3517 if (first->op_type != (unsigned)type)
2fcb4757 3518 return op_prepend_elem(type, first, last);
8990e307 3519
fe2774ed 3520 if (last->op_type != (unsigned)type)
2fcb4757 3521 return op_append_elem(type, first, last);
79072805 3522
2fcb4757
Z
3523 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3524 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3525 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3526
eb8433b7 3527#ifdef PERL_MAD
2fcb4757
Z
3528 if (((LISTOP*)last)->op_first && first->op_madprop) {
3529 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC
3530 if (mp) {
3531 while (mp->mad_next)
3532 mp = mp->mad_next;
3533 mp->mad_next = first->op_madprop;
3534 }
3535 else {
2fcb4757 3536 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC
3537 }
3538 }
3539 first->op_madprop = last->op_madprop;
3540 last->op_madprop = 0;
3541#endif
3542
2fcb4757 3543 S_op_destroy(aTHX_ last);
238a4c30 3544
2fcb4757 3545 return first;
79072805
LW
3546}
3547
2fcb4757
Z
3548/*
3549=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3550
3551Prepend an item to the list of ops contained directly within a list-type
3552op, returning the lengthened list. I<first> is the op to prepend to the
3553list, and I<last> is the list-type op. I<optype> specifies the intended
3554opcode for the list. If I<last> is not already a list of the right type,
3555it will be upgraded into one. If either I<first> or I<last> is null,
3556the other is returned unchanged.
3557
3558=cut
3559*/
3560
79072805 3561OP *
2fcb4757 3562Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3563{
3564 if (!first)
3565 return last;
8990e307
LW
3566
3567 if (!last)
79072805 3568 return first;
8990e307 3569
fe2774ed 3570 if (last->op_type == (unsigned)type) {
8990e307
LW
3571 if (type == OP_LIST) { /* already a PUSHMARK there */
3572 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3573 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
3574 if (!(first->op_flags & OPf_PARENS))
3575 last->op_flags &= ~OPf_PARENS;
8990e307
LW
3576 }
3577 else {
3578 if (!(last->op_flags & OPf_KIDS)) {
3579 ((LISTOP*)last)->op_last = first;
3580 last->op_flags |= OPf_KIDS;
3581 }
3582 first->op_sibling = ((LISTOP*)last)->op_first;
3583 ((LISTOP*)last)->op_first = first;
79072805 3584 }
117dada2 3585 last->op_flags |= OPf_KIDS;
79072805
LW
3586 return last;
3587 }
3588
3589 return newLISTOP(type, 0, first, last);
3590}
3591
3592/* Constructors */
3593
eb8433b7
NC
3594#ifdef PERL_MAD
3595
3596TOKEN *
3597Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3598{
3599 TOKEN *tk;
99129197 3600 Newxz(tk, 1, TOKEN);
eb8433b7
NC
3601 tk->tk_type = (OPCODE)optype;
3602 tk->tk_type = 12345;
3603 tk->tk_lval = lval;
3604 tk->tk_mad = madprop;
3605 return tk;
3606}
3607
3608void
3609Perl_token_free(pTHX_ TOKEN* tk)
3610{
7918f24d
NC
3611 PERL_ARGS_ASSERT_TOKEN_FREE;
3612
eb8433b7
NC
3613 if (tk->tk_type != 12345)
3614 return;
3615 mad_free(tk->tk_mad);
3616 Safefree(tk);
3617}
3618
3619void
3620Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3621{
3622 MADPROP* mp;
3623 MADPROP* tm;
7918f24d
NC
3624
3625 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3626
eb8433b7
NC
3627 if (tk->tk_type != 12345) {
3628 Perl_warner(aTHX_ packWARN(WARN_MISC),
3629 "Invalid TOKEN object ignored");
3630 return;
3631 }
3632 tm = tk->tk_mad;
3633 if (!tm)
3634 return;
3635
3636 /* faked up qw list? */
3637 if (slot == '(' &&
3638 tm->mad_type == MAD_SV &&