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