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