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