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