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