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