This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #119043] Exempt shared hash key consts from ro
[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
638Perl_alloccopstash(pTHX_ HV *hv)
639{
640 PADOFFSET off = 0, o = 1;
641 bool found_slot = FALSE;
642
643 PERL_ARGS_ASSERT_ALLOCCOPSTASH;
644
645 if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
646
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)
650 found_slot = TRUE, off = o;
651 }
652 if (!found_slot) {
653 Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
654 Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
655 off = PL_stashpadmax;
656 PL_stashpadmax += 10;
657 }
658
659 PL_stashpad[PL_stashpadix = off] = hv;
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));
3eb57f73
HS
928}
929
c2b1997a 930STATIC void
c4bd3ae5 931S_forget_pmop(pTHX_ PMOP *const o
c4bd3ae5 932 )
c2b1997a
NC
933{
934 HV * const pmstash = PmopSTASH(o);
7918f24d
NC
935
936 PERL_ARGS_ASSERT_FORGET_PMOP;
937
e39a6381 938 if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
ad64d0ec 939 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
c2b1997a
NC
940 if (mg) {
941 PMOP **const array = (PMOP**) mg->mg_ptr;
942 U32 count = mg->mg_len / sizeof(PMOP**);
943 U32 i = count;
944
945 while (i--) {
946 if (array[i] == o) {
947 /* Found it. Move the entry at the end to overwrite it. */
948 array[i] = array[--count];
949 mg->mg_len = count * sizeof(PMOP**);
950 /* Could realloc smaller at this point always, but probably
951 not worth it. Probably worth free()ing if we're the
952 last. */
953 if(!count) {
954 Safefree(mg->mg_ptr);
955 mg->mg_ptr = NULL;
956 }
957 break;
958 }
959 }
960 }
961 }
1cdf7faf
NC
962 if (PL_curpm == o)
963 PL_curpm = NULL;
c2b1997a
NC
964}
965
bfd0ff22
NC
966STATIC void
967S_find_and_forget_pmops(pTHX_ OP *o)
968{
7918f24d
NC
969 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
970
bfd0ff22
NC
971 if (o->op_flags & OPf_KIDS) {
972 OP *kid = cUNOPo->op_first;
973 while (kid) {
974 switch (kid->op_type) {
975 case OP_SUBST:
976 case OP_PUSHRE:
977 case OP_MATCH:
978 case OP_QR:
23083432 979 forget_pmop((PMOP*)kid);
bfd0ff22
NC
980 }
981 find_and_forget_pmops(kid);
982 kid = kid->op_sibling;
983 }
984 }
985}
986
93c66552
DM
987void
988Perl_op_null(pTHX_ OP *o)
8990e307 989{
27da23d5 990 dVAR;
7918f24d
NC
991
992 PERL_ARGS_ASSERT_OP_NULL;
993
acb36ea4
GS
994 if (o->op_type == OP_NULL)
995 return;
eb8433b7
NC
996 if (!PL_madskills)
997 op_clear(o);
11343788
MB
998 o->op_targ = o->op_type;
999 o->op_type = OP_NULL;
22c35a8c 1000 o->op_ppaddr = PL_ppaddr[OP_NULL];
8990e307
LW
1001}
1002
4026c95a
SH
1003void
1004Perl_op_refcnt_lock(pTHX)
1005{
27da23d5 1006 dVAR;
96a5add6 1007 PERL_UNUSED_CONTEXT;
4026c95a
SH
1008 OP_REFCNT_LOCK;
1009}
1010
1011void
1012Perl_op_refcnt_unlock(pTHX)
1013{
27da23d5 1014 dVAR;
96a5add6 1015 PERL_UNUSED_CONTEXT;
4026c95a
SH
1016 OP_REFCNT_UNLOCK;
1017}
1018
79072805
LW
1019/* Contextualizers */
1020
d9088386
Z
1021/*
1022=for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1023
1024Applies a syntactic context to an op tree representing an expression.
1025I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1026or C<G_VOID> to specify the context to apply. The modified op tree
1027is returned.
1028
1029=cut
1030*/
1031
1032OP *
1033Perl_op_contextualize(pTHX_ OP *o, I32 context)
1034{
1035 PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1036 switch (context) {
1037 case G_SCALAR: return scalar(o);
1038 case G_ARRAY: return list(o);
1039 case G_VOID: return scalarvoid(o);
1040 default:
5637ef5b
NC
1041 Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1042 (long) context);
d9088386
Z
1043 return o;
1044 }
1045}
1046
5983a79d
BM
1047/*
1048=head1 Optree Manipulation Functions
79072805 1049
5983a79d
BM
1050=for apidoc Am|OP*|op_linklist|OP *o
1051This function is the implementation of the L</LINKLIST> macro. It should
1052not be called directly.
1053
1054=cut
1055*/
1056
1057OP *
1058Perl_op_linklist(pTHX_ OP *o)
79072805 1059{
3edf23ff 1060 OP *first;
79072805 1061
5983a79d 1062 PERL_ARGS_ASSERT_OP_LINKLIST;
7918f24d 1063
11343788
MB
1064 if (o->op_next)
1065 return o->op_next;
79072805
LW
1066
1067 /* establish postfix order */
3edf23ff
AL
1068 first = cUNOPo->op_first;
1069 if (first) {
eb578fdb 1070 OP *kid;
3edf23ff
AL
1071 o->op_next = LINKLIST(first);
1072 kid = first;
1073 for (;;) {
1074 if (kid->op_sibling) {
79072805 1075 kid->op_next = LINKLIST(kid->op_sibling);
3edf23ff
AL
1076 kid = kid->op_sibling;
1077 } else {
11343788 1078 kid->op_next = o;
3edf23ff
AL
1079 break;
1080 }
79072805
LW
1081 }
1082 }
1083 else
11343788 1084 o->op_next = o;
79072805 1085
11343788 1086 return o->op_next;
79072805
LW
1087}
1088
1f676739 1089static OP *
2dd5337b 1090S_scalarkids(pTHX_ OP *o)
79072805 1091{
11343788 1092 if (o && o->op_flags & OPf_KIDS) {
bfed75c6 1093 OP *kid;
11343788 1094 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1095 scalar(kid);
1096 }
11343788 1097 return o;
79072805
LW
1098}
1099
76e3520e 1100STATIC OP *
cea2e8a9 1101S_scalarboolean(pTHX_ OP *o)
8990e307 1102{
97aff369 1103 dVAR;
7918f24d
NC
1104
1105 PERL_ARGS_ASSERT_SCALARBOOLEAN;
1106
6b7c6d95
FC
1107 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1108 && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
d008e5eb 1109 if (ckWARN(WARN_SYNTAX)) {
6867be6d 1110 const line_t oldline = CopLINE(PL_curcop);
a0d0e21e 1111
2b7cddde
NC
1112 if (PL_parser && PL_parser->copline != NOLINE) {
1113 /* This ensures that warnings are reported at the first line
1114 of the conditional, not the last. */
53a7735b 1115 CopLINE_set(PL_curcop, PL_parser->copline);
2b7cddde 1116 }
9014280d 1117 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
57843af0 1118 CopLINE_set(PL_curcop, oldline);
d008e5eb 1119 }
a0d0e21e 1120 }
11343788 1121 return scalar(o);
8990e307
LW
1122}
1123
1124OP *
864dbfa3 1125Perl_scalar(pTHX_ OP *o)
79072805 1126{
27da23d5 1127 dVAR;
79072805
LW
1128 OP *kid;
1129
a0d0e21e 1130 /* assumes no premature commitment */
13765c85
DM
1131 if (!o || (PL_parser && PL_parser->error_count)
1132 || (o->op_flags & OPf_WANT)
5dc0d613 1133 || o->op_type == OP_RETURN)
7e363e51 1134 {
11343788 1135 return o;
7e363e51 1136 }
79072805 1137
5dc0d613 1138 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
79072805 1139
11343788 1140 switch (o->op_type) {
79072805 1141 case OP_REPEAT:
11343788 1142 scalar(cBINOPo->op_first);
8990e307 1143 break;
79072805
LW
1144 case OP_OR:
1145 case OP_AND:
1146 case OP_COND_EXPR:
11343788 1147 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
8990e307 1148 scalar(kid);
79072805 1149 break;
a0d0e21e 1150 /* FALL THROUGH */
a6d8037e 1151 case OP_SPLIT:
79072805 1152 case OP_MATCH:
8782bef2 1153 case OP_QR:
79072805
LW
1154 case OP_SUBST:
1155 case OP_NULL:
8990e307 1156 default:
11343788
MB
1157 if (o->op_flags & OPf_KIDS) {
1158 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
8990e307
LW
1159 scalar(kid);
1160 }
79072805
LW
1161 break;
1162 case OP_LEAVE:
1163 case OP_LEAVETRY:
5dc0d613 1164 kid = cLISTOPo->op_first;
54310121 1165 scalar(kid);
25b991bf
VP
1166 kid = kid->op_sibling;
1167 do_kids:
1168 while (kid) {
1169 OP *sib = kid->op_sibling;
c08f093b
VP
1170 if (sib && kid->op_type != OP_LEAVEWHEN)
1171 scalarvoid(kid);
1172 else
54310121 1173 scalar(kid);
25b991bf 1174 kid = sib;
54310121 1175 }
11206fdd 1176 PL_curcop = &PL_compiling;
54310121 1177 break;
748a9306 1178 case OP_SCOPE:
79072805 1179 case OP_LINESEQ:
8990e307 1180 case OP_LIST:
25b991bf
VP
1181 kid = cLISTOPo->op_first;
1182 goto do_kids;
a801c63c 1183 case OP_SORT:
a2a5de95 1184 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
553e7bb0 1185 break;
79072805 1186 }
11343788 1187 return o;
79072805
LW
1188}
1189
1190OP *
864dbfa3 1191Perl_scalarvoid(pTHX_ OP *o)
79072805 1192{
27da23d5 1193 dVAR;
79072805 1194 OP *kid;
095b19d1 1195 SV *useless_sv = NULL;
c445ea15 1196 const char* useless = NULL;
8990e307 1197 SV* sv;
2ebea0a1
GS
1198 U8 want;
1199
7918f24d
NC
1200 PERL_ARGS_ASSERT_SCALARVOID;
1201
eb8433b7
NC
1202 /* trailing mad null ops don't count as "there" for void processing */
1203 if (PL_madskills &&
1204 o->op_type != OP_NULL &&
1205 o->op_sibling &&
1206 o->op_sibling->op_type == OP_NULL)
1207 {
1208 OP *sib;
1209 for (sib = o->op_sibling;
1210 sib && sib->op_type == OP_NULL;
1211 sib = sib->op_sibling) ;
1212
1213 if (!sib)
1214 return o;
1215 }
1216
acb36ea4 1217 if (o->op_type == OP_NEXTSTATE
acb36ea4
GS
1218 || o->op_type == OP_DBSTATE
1219 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
acb36ea4 1220 || o->op_targ == OP_DBSTATE)))
2ebea0a1 1221 PL_curcop = (COP*)o; /* for warning below */
79072805 1222
54310121 1223 /* assumes no premature commitment */
2ebea0a1 1224 want = o->op_flags & OPf_WANT;
13765c85
DM
1225 if ((want && want != OPf_WANT_SCALAR)
1226 || (PL_parser && PL_parser->error_count)
25b991bf 1227 || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
7e363e51 1228 {
11343788 1229 return o;
7e363e51 1230 }
79072805 1231
b162f9ea 1232 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1233 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1234 {
b162f9ea 1235 return scalar(o); /* As if inside SASSIGN */
7e363e51 1236 }
1c846c1f 1237
5dc0d613 1238 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
79072805 1239
11343788 1240 switch (o->op_type) {
79072805 1241 default:
22c35a8c 1242 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
8990e307 1243 break;
36477c24
PP
1244 /* FALL THROUGH */
1245 case OP_REPEAT:
11343788 1246 if (o->op_flags & OPf_STACKED)
8990e307 1247 break;
5d82c453
GA
1248 goto func_ops;
1249 case OP_SUBSTR:
1250 if (o->op_private == 4)
1251 break;
8990e307
LW
1252 /* FALL THROUGH */
1253 case OP_GVSV:
1254 case OP_WANTARRAY:
1255 case OP_GV:
74295f0b 1256 case OP_SMARTMATCH:
8990e307
LW
1257 case OP_PADSV:
1258 case OP_PADAV:
1259 case OP_PADHV:
1260 case OP_PADANY:
1261 case OP_AV2ARYLEN:
8990e307 1262 case OP_REF:
a0d0e21e
LW
1263 case OP_REFGEN:
1264 case OP_SREFGEN:
8990e307
LW
1265 case OP_DEFINED:
1266 case OP_HEX:
1267 case OP_OCT:
1268 case OP_LENGTH:
8990e307
LW
1269 case OP_VEC:
1270 case OP_INDEX:
1271 case OP_RINDEX:
1272 case OP_SPRINTF:
1273 case OP_AELEM:
1274 case OP_AELEMFAST:
93bad3fd 1275 case OP_AELEMFAST_LEX:
8990e307 1276 case OP_ASLICE:
8990e307
LW
1277 case OP_HELEM:
1278 case OP_HSLICE:
1279 case OP_UNPACK:
1280 case OP_PACK:
8990e307
LW
1281 case OP_JOIN:
1282 case OP_LSLICE:
1283 case OP_ANONLIST:
1284 case OP_ANONHASH:
1285 case OP_SORT:
1286 case OP_REVERSE:
1287 case OP_RANGE:
1288 case OP_FLIP:
1289 case OP_FLOP:
1290 case OP_CALLER:
1291 case OP_FILENO:
1292 case OP_EOF:
1293 case OP_TELL:
1294 case OP_GETSOCKNAME:
1295 case OP_GETPEERNAME:
1296 case OP_READLINK:
1297 case OP_TELLDIR:
1298 case OP_GETPPID:
1299 case OP_GETPGRP:
1300 case OP_GETPRIORITY:
1301 case OP_TIME:
1302 case OP_TMS:
1303 case OP_LOCALTIME:
1304 case OP_GMTIME:
1305 case OP_GHBYNAME:
1306 case OP_GHBYADDR:
1307 case OP_GHOSTENT:
1308 case OP_GNBYNAME:
1309 case OP_GNBYADDR:
1310 case OP_GNETENT:
1311 case OP_GPBYNAME:
1312 case OP_GPBYNUMBER:
1313 case OP_GPROTOENT:
1314 case OP_GSBYNAME:
1315 case OP_GSBYPORT:
1316 case OP_GSERVENT:
1317 case OP_GPWNAM:
1318 case OP_GPWUID:
1319 case OP_GGRNAM:
1320 case OP_GGRGID:
1321 case OP_GETLOGIN:
78e1b766 1322 case OP_PROTOTYPE:
703227f5 1323 case OP_RUNCV:
5d82c453 1324 func_ops:
64aac5a9 1325 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
74295f0b 1326 /* Otherwise it's "Useless use of grep iterator" */
f5df4782 1327 useless = OP_DESC(o);
75068674
RGS
1328 break;
1329
1330 case OP_SPLIT:
1331 kid = cLISTOPo->op_first;
1332 if (kid && kid->op_type == OP_PUSHRE
1333#ifdef USE_ITHREADS
1334 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1335#else
1336 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1337#endif
1338 useless = OP_DESC(o);
8990e307
LW
1339 break;
1340
9f82cd5f
YST
1341 case OP_NOT:
1342 kid = cUNOPo->op_first;
1343 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
bb16bae8 1344 kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
9f82cd5f
YST
1345 goto func_ops;
1346 }
1347 useless = "negative pattern binding (!~)";
1348 break;
1349
4f4d7508
DC
1350 case OP_SUBST:
1351 if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
8db9069c 1352 useless = "non-destructive substitution (s///r)";
4f4d7508
DC
1353 break;
1354
bb16bae8
FC
1355 case OP_TRANSR:
1356 useless = "non-destructive transliteration (tr///r)";
1357 break;
1358
8990e307
LW
1359 case OP_RV2GV:
1360 case OP_RV2SV:
1361 case OP_RV2AV:
1362 case OP_RV2HV:
192587c2 1363 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
11343788 1364 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
8990e307
LW
1365 useless = "a variable";
1366 break;
79072805
LW
1367
1368 case OP_CONST:
7766f137 1369 sv = cSVOPo_sv;
7a52d87a
GS
1370 if (cSVOPo->op_private & OPpCONST_STRICT)
1371 no_bareword_allowed(o);
1372 else {
d008e5eb 1373 if (ckWARN(WARN_VOID)) {
e7fec78e 1374 /* don't warn on optimised away booleans, eg
b5a930ec 1375 * use constant Foo, 5; Foo || print; */
e7fec78e 1376 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
d4c19fe8 1377 useless = NULL;
960b4253
MG
1378 /* the constants 0 and 1 are permitted as they are
1379 conventionally used as dummies in constructs like
1380 1 while some_condition_with_side_effects; */
e7fec78e 1381 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
d4c19fe8 1382 useless = NULL;
d008e5eb 1383 else if (SvPOK(sv)) {
1e3f3188
KW
1384 SV * const dsv = newSVpvs("");
1385 useless_sv
1386 = Perl_newSVpvf(aTHX_
1387 "a constant (%s)",
1388 pv_pretty(dsv, SvPVX_const(sv),
1389 SvCUR(sv), 32, NULL, NULL,
1390 PERL_PV_PRETTY_DUMP
1391 | PERL_PV_ESCAPE_NOCLEAR
1392 | PERL_PV_ESCAPE_UNI_DETECT));
1393 SvREFCNT_dec_NN(dsv);
d008e5eb 1394 }
919f76a3 1395 else if (SvOK(sv)) {
095b19d1 1396 useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
919f76a3
RGS
1397 }
1398 else
1399 useless = "a constant (undef)";
8990e307
LW
1400 }
1401 }
93c66552 1402 op_null(o); /* don't execute or even remember it */
79072805
LW
1403 break;
1404
1405 case OP_POSTINC:
11343788 1406 o->op_type = OP_PREINC; /* pre-increment is faster */
22c35a8c 1407 o->op_ppaddr = PL_ppaddr[OP_PREINC];
79072805
LW
1408 break;
1409
1410 case OP_POSTDEC:
11343788 1411 o->op_type = OP_PREDEC; /* pre-decrement is faster */
22c35a8c 1412 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
79072805
LW
1413 break;
1414
679d6c4e
HS
1415 case OP_I_POSTINC:
1416 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1417 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1418 break;
1419
1420 case OP_I_POSTDEC:
1421 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1422 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1423 break;
1424
f2f8fd84
GG
1425 case OP_SASSIGN: {
1426 OP *rv2gv;
1427 UNOP *refgen, *rv2cv;
1428 LISTOP *exlist;
1429
1430 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1431 break;
1432
1433 rv2gv = ((BINOP *)o)->op_last;
1434 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1435 break;
1436
1437 refgen = (UNOP *)((BINOP *)o)->op_first;
1438
1439 if (!refgen || refgen->op_type != OP_REFGEN)
1440 break;
1441
1442 exlist = (LISTOP *)refgen->op_first;
1443 if (!exlist || exlist->op_type != OP_NULL
1444 || exlist->op_targ != OP_LIST)
1445 break;
1446
1447 if (exlist->op_first->op_type != OP_PUSHMARK)
1448 break;
1449
1450 rv2cv = (UNOP*)exlist->op_last;
1451
1452 if (rv2cv->op_type != OP_RV2CV)
1453 break;
1454
1455 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1456 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1457 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1458
1459 o->op_private |= OPpASSIGN_CV_TO_GV;
1460 rv2gv->op_private |= OPpDONT_INIT_GV;
1461 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1462
1463 break;
1464 }
1465
540dd770
GG
1466 case OP_AASSIGN: {
1467 inplace_aassign(o);
1468 break;
1469 }
1470
79072805
LW
1471 case OP_OR:
1472 case OP_AND:
edbe35ea
VP
1473 kid = cLOGOPo->op_first;
1474 if (kid->op_type == OP_NOT
1475 && (kid->op_flags & OPf_KIDS)
1476 && !PL_madskills) {
1477 if (o->op_type == OP_AND) {
1478 o->op_type = OP_OR;
1479 o->op_ppaddr = PL_ppaddr[OP_OR];
1480 } else {
1481 o->op_type = OP_AND;
1482 o->op_ppaddr = PL_ppaddr[OP_AND];
1483 }
1484 op_null(kid);
1485 }
1486
c963b151 1487 case OP_DOR:
79072805 1488 case OP_COND_EXPR:
0d863452
RH
1489 case OP_ENTERGIVEN:
1490 case OP_ENTERWHEN:
11343788 1491 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1492 scalarvoid(kid);
1493 break;
5aabfad6 1494
a0d0e21e 1495 case OP_NULL:
11343788 1496 if (o->op_flags & OPf_STACKED)
a0d0e21e 1497 break;
5aabfad6 1498 /* FALL THROUGH */
2ebea0a1
GS
1499 case OP_NEXTSTATE:
1500 case OP_DBSTATE:
79072805
LW
1501 case OP_ENTERTRY:
1502 case OP_ENTER:
11343788 1503 if (!(o->op_flags & OPf_KIDS))
79072805 1504 break;
54310121 1505 /* FALL THROUGH */
463ee0b2 1506 case OP_SCOPE:
79072805
LW
1507 case OP_LEAVE:
1508 case OP_LEAVETRY:
a0d0e21e 1509 case OP_LEAVELOOP:
79072805 1510 case OP_LINESEQ:
79072805 1511 case OP_LIST:
0d863452
RH
1512 case OP_LEAVEGIVEN:
1513 case OP_LEAVEWHEN:
11343788 1514 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1515 scalarvoid(kid);
1516 break;
c90c0ff4 1517 case OP_ENTEREVAL:
5196be3e 1518 scalarkids(o);
c90c0ff4 1519 break;
d6483035 1520 case OP_SCALAR:
5196be3e 1521 return scalar(o);
79072805 1522 }
095b19d1
NC
1523
1524 if (useless_sv) {
1525 /* mortalise it, in case warnings are fatal. */
1526 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1527 "Useless use of %"SVf" in void context",
1528 sv_2mortal(useless_sv));
1529 }
1530 else if (useless) {
1531 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1532 "Useless use of %s in void context",
1533 useless);
1534 }
11343788 1535 return o;
79072805
LW
1536}
1537
1f676739 1538static OP *
412da003 1539S_listkids(pTHX_ OP *o)
79072805 1540{
11343788 1541 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1542 OP *kid;
11343788 1543 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
79072805
LW
1544 list(kid);
1545 }
11343788 1546 return o;
79072805
LW
1547}
1548
1549OP *
864dbfa3 1550Perl_list(pTHX_ OP *o)
79072805 1551{
27da23d5 1552 dVAR;
79072805
LW
1553 OP *kid;
1554
a0d0e21e 1555 /* assumes no premature commitment */
13765c85
DM
1556 if (!o || (o->op_flags & OPf_WANT)
1557 || (PL_parser && PL_parser->error_count)
5dc0d613 1558 || o->op_type == OP_RETURN)
7e363e51 1559 {
11343788 1560 return o;
7e363e51 1561 }
79072805 1562
b162f9ea 1563 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1564 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1565 {
b162f9ea 1566 return o; /* As if inside SASSIGN */
7e363e51 1567 }
1c846c1f 1568
5dc0d613 1569 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
79072805 1570
11343788 1571 switch (o->op_type) {
79072805
LW
1572 case OP_FLOP:
1573 case OP_REPEAT:
11343788 1574 list(cBINOPo->op_first);
79072805
LW
1575 break;
1576 case OP_OR:
1577 case OP_AND:
1578 case OP_COND_EXPR:
11343788 1579 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
79072805
LW
1580 list(kid);
1581 break;
1582 default:
1583 case OP_MATCH:
8782bef2 1584 case OP_QR:
79072805
LW
1585 case OP_SUBST:
1586 case OP_NULL:
11343788 1587 if (!(o->op_flags & OPf_KIDS))
79072805 1588 break;
11343788
MB
1589 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1590 list(cBINOPo->op_first);
1591 return gen_constant_list(o);
79072805
LW
1592 }
1593 case OP_LIST:
11343788 1594 listkids(o);
79072805
LW
1595 break;
1596 case OP_LEAVE:
1597 case OP_LEAVETRY:
5dc0d613 1598 kid = cLISTOPo->op_first;
54310121 1599 list(kid);
25b991bf
VP
1600 kid = kid->op_sibling;
1601 do_kids:
1602 while (kid) {
1603 OP *sib = kid->op_sibling;
c08f093b
VP
1604 if (sib && kid->op_type != OP_LEAVEWHEN)
1605 scalarvoid(kid);
1606 else
54310121 1607 list(kid);
25b991bf 1608 kid = sib;
54310121 1609 }
11206fdd 1610 PL_curcop = &PL_compiling;
54310121 1611 break;
748a9306 1612 case OP_SCOPE:
79072805 1613 case OP_LINESEQ:
25b991bf
VP
1614 kid = cLISTOPo->op_first;
1615 goto do_kids;
79072805 1616 }
11343788 1617 return o;
79072805
LW
1618}
1619
1f676739 1620static OP *
2dd5337b 1621S_scalarseq(pTHX_ OP *o)
79072805 1622{
97aff369 1623 dVAR;
11343788 1624 if (o) {
1496a290
AL
1625 const OPCODE type = o->op_type;
1626
1627 if (type == OP_LINESEQ || type == OP_SCOPE ||
1628 type == OP_LEAVE || type == OP_LEAVETRY)
463ee0b2 1629 {
6867be6d 1630 OP *kid;
11343788 1631 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
ed6116ce 1632 if (kid->op_sibling) {
463ee0b2 1633 scalarvoid(kid);
ed6116ce 1634 }
463ee0b2 1635 }
3280af22 1636 PL_curcop = &PL_compiling;
79072805 1637 }
11343788 1638 o->op_flags &= ~OPf_PARENS;
3280af22 1639 if (PL_hints & HINT_BLOCK_SCOPE)
11343788 1640 o->op_flags |= OPf_PARENS;
79072805 1641 }
8990e307 1642 else
11343788
MB
1643 o = newOP(OP_STUB, 0);
1644 return o;
79072805
LW
1645}
1646
76e3520e 1647STATIC OP *
cea2e8a9 1648S_modkids(pTHX_ OP *o, I32 type)
79072805 1649{
11343788 1650 if (o && o->op_flags & OPf_KIDS) {
6867be6d 1651 OP *kid;
11343788 1652 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
3ad73efd 1653 op_lvalue(kid, type);
79072805 1654 }
11343788 1655 return o;
79072805
LW
1656}
1657
3ad73efd 1658/*
d164302a
GG
1659=for apidoc finalize_optree
1660
1661This function finalizes the optree. Should be called directly after
1662the complete optree is built. It does some additional
1663checking which can't be done in the normal ck_xxx functions and makes
1664the tree thread-safe.
1665
1666=cut
1667*/
1668void
1669Perl_finalize_optree(pTHX_ OP* o)
1670{
1671 PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1672
1673 ENTER;
1674 SAVEVPTR(PL_curcop);
1675
1676 finalize_op(o);
1677
1678 LEAVE;
1679}
1680
60dde6b2 1681STATIC void
d164302a
GG
1682S_finalize_op(pTHX_ OP* o)
1683{
1684 PERL_ARGS_ASSERT_FINALIZE_OP;
1685
1686#if defined(PERL_MAD) && defined(USE_ITHREADS)
1687 {
1688 /* Make sure mad ops are also thread-safe */
1689 MADPROP *mp = o->op_madprop;
1690 while (mp) {
1691 if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1692 OP *prop_op = (OP *) mp->mad_val;
1693 /* We only need "Relocate sv to the pad for thread safety.", but this
1694 easiest way to make sure it traverses everything */
4dc304e0
FC
1695 if (prop_op->op_type == OP_CONST)
1696 cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
d164302a
GG
1697 finalize_op(prop_op);
1698 }
1699 mp = mp->mad_next;
1700 }
1701 }
1702#endif
1703
1704 switch (o->op_type) {
1705 case OP_NEXTSTATE:
1706 case OP_DBSTATE:
1707 PL_curcop = ((COP*)o); /* for warnings */
1708 break;
1709 case OP_EXEC:
ea31ed66
GG
1710 if ( o->op_sibling
1711 && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
573d2b1a 1712 && ckWARN(WARN_EXEC))
d164302a 1713 {
ea31ed66
GG
1714 if (o->op_sibling->op_sibling) {
1715 const OPCODE type = o->op_sibling->op_sibling->op_type;
d164302a
GG
1716 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1717 const line_t oldline = CopLINE(PL_curcop);
ea31ed66 1718 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
d164302a
GG
1719 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1720 "Statement unlikely to be reached");
1721 Perl_warner(aTHX_ packWARN(WARN_EXEC),
1722 "\t(Maybe you meant system() when you said exec()?)\n");
1723 CopLINE_set(PL_curcop, oldline);
1724 }
1725 }
1726 }
1727 break;
1728
1729 case OP_GV:
1730 if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1731 GV * const gv = cGVOPo_gv;
1732 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1733 /* XXX could check prototype here instead of just carping */
1734 SV * const sv = sv_newmortal();
1735 gv_efullname3(sv, gv, NULL);
1736 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1737 "%"SVf"() called too early to check prototype",
1738 SVfARG(sv));
1739 }
1740 }
1741 break;
1742
1743 case OP_CONST:
eb796c7f
GG
1744 if (cSVOPo->op_private & OPpCONST_STRICT)
1745 no_bareword_allowed(o);
1746 /* FALLTHROUGH */
d164302a
GG
1747#ifdef USE_ITHREADS
1748 case OP_HINTSEVAL:
1749 case OP_METHOD_NAMED:
1750 /* Relocate sv to the pad for thread safety.
1751 * Despite being a "constant", the SV is written to,
1752 * for reference counts, sv_upgrade() etc. */
1753 if (cSVOPo->op_sv) {
325e1816 1754 const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
82b84d04 1755 if (o->op_type != OP_METHOD_NAMED
d164302a
GG
1756 && cSVOPo->op_sv == &PL_sv_undef) {
1757 /* PL_sv_undef is hack - it's unsafe to store it in the
1758 AV that is the pad, because av_fetch treats values of
1759 PL_sv_undef as a "free" AV entry and will merrily
1760 replace them with a new SV, causing pad_alloc to think
1761 that this pad slot is free. (When, clearly, it is not)
1762 */
1763 SvOK_off(PAD_SVl(ix));
1764 SvPADTMP_on(PAD_SVl(ix));
1765 SvREADONLY_on(PAD_SVl(ix));
1766 }
1767 else {
1768 SvREFCNT_dec(PAD_SVl(ix));
d164302a
GG
1769 PAD_SETSV(ix, cSVOPo->op_sv);
1770 /* XXX I don't know how this isn't readonly already. */
e3918bb7 1771 if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
d164302a
GG
1772 }
1773 cSVOPo->op_sv = NULL;
1774 o->op_targ = ix;
1775 }
1776#endif
1777 break;
1778
1779 case OP_HELEM: {
1780 UNOP *rop;
1781 SV *lexname;
1782 GV **fields;
1783 SV **svp, *sv;
1784 const char *key = NULL;
1785 STRLEN keylen;
1786
1787 if (((BINOP*)o)->op_last->op_type != OP_CONST)
1788 break;
1789
1790 /* Make the CONST have a shared SV */
1791 svp = cSVOPx_svp(((BINOP*)o)->op_last);
e3918bb7 1792 if ((!SvIsCOW(sv = *svp))
d164302a
GG
1793 && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
1794 key = SvPV_const(sv, keylen);
1795 lexname = newSVpvn_share(key,
1796 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
1797 0);
fc2b2dca 1798 SvREFCNT_dec_NN(sv);
d164302a
GG
1799 *svp = lexname;
1800 }
1801
1802 if ((o->op_private & (OPpLVAL_INTRO)))
1803 break;
1804
1805 rop = (UNOP*)((BINOP*)o)->op_first;
1806 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
1807 break;
1808 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
1809 if (!SvPAD_TYPED(lexname))
1810 break;
1811 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1812 if (!fields || !GvHV(*fields))
1813 break;
1814 key = SvPV_const(*svp, keylen);
1815 if (!hv_fetch(GvHV(*fields), key,
1816 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1817 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1818 "in variable %"SVf" of type %"HEKf,
ce16c625 1819 SVfARG(*svp), SVfARG(lexname),
84cf752c 1820 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG
1821 }
1822 break;
1823 }
1824
1825 case OP_HSLICE: {
1826 UNOP *rop;
1827 SV *lexname;
1828 GV **fields;
1829 SV **svp;
1830 const char *key;
1831 STRLEN keylen;
1832 SVOP *first_key_op, *key_op;
1833
1834 if ((o->op_private & (OPpLVAL_INTRO))
1835 /* I bet there's always a pushmark... */
1836 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
1837 /* hmmm, no optimization if list contains only one key. */
1838 break;
1839 rop = (UNOP*)((LISTOP*)o)->op_last;
1840 if (rop->op_type != OP_RV2HV)
1841 break;
1842 if (rop->op_first->op_type == OP_PADSV)
1843 /* @$hash{qw(keys here)} */
1844 rop = (UNOP*)rop->op_first;
1845 else {
1846 /* @{$hash}{qw(keys here)} */
1847 if (rop->op_first->op_type == OP_SCOPE
1848 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
1849 {
1850 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
1851 }
1852 else
1853 break;
1854 }
1855
1856 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
1857 if (!SvPAD_TYPED(lexname))
1858 break;
1859 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
1860 if (!fields || !GvHV(*fields))
1861 break;
1862 /* Again guessing that the pushmark can be jumped over.... */
1863 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
1864 ->op_first->op_sibling;
1865 for (key_op = first_key_op; key_op;
1866 key_op = (SVOP*)key_op->op_sibling) {
1867 if (key_op->op_type != OP_CONST)
1868 continue;
1869 svp = cSVOPx_svp(key_op);
1870 key = SvPV_const(*svp, keylen);
1871 if (!hv_fetch(GvHV(*fields), key,
1872 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
ce16c625 1873 Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
84cf752c 1874 "in variable %"SVf" of type %"HEKf,
ce16c625 1875 SVfARG(*svp), SVfARG(lexname),
84cf752c 1876 HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
d164302a
GG
1877 }
1878 }
1879 break;
1880 }
a7fd8ef6 1881
d164302a
GG
1882 case OP_SUBST: {
1883 if (cPMOPo->op_pmreplrootu.op_pmreplroot)
1884 finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
1885 break;
1886 }
1887 default:
1888 break;
1889 }
1890
1891 if (o->op_flags & OPf_KIDS) {
1892 OP *kid;
1893 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1894 finalize_op(kid);
1895 }
1896}
1897
1898/*
3ad73efd
Z
1899=for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
1900
1901Propagate lvalue ("modifiable") context to an op and its children.
1902I<type> represents the context type, roughly based on the type of op that
1903would do the modifying, although C<local()> is represented by OP_NULL,
1904because it has no op type of its own (it is signalled by a flag on
001c3c51
FC
1905the lvalue op).
1906
1907This function detects things that can't be modified, such as C<$x+1>, and
1908generates errors for them. For example, C<$x+1 = 2> would cause it to be
1909called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
1910
1911It also flags things that need to behave specially in an lvalue context,
1912such as C<$$x = 5> which might have to vivify a reference in C<$x>.
3ad73efd
Z
1913
1914=cut
1915*/
ddeae0f1 1916
79072805 1917OP *
d3d7d28f 1918Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
79072805 1919{
27da23d5 1920 dVAR;
79072805 1921 OP *kid;
ddeae0f1
DM
1922 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1923 int localize = -1;
79072805 1924
13765c85 1925 if (!o || (PL_parser && PL_parser->error_count))
11343788 1926 return o;
79072805 1927
b162f9ea 1928 if ((o->op_private & OPpTARGET_MY)
7e363e51
GS
1929 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1930 {
b162f9ea 1931 return o;
7e363e51 1932 }
1c846c1f 1933
5c906035
GG
1934 assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
1935
69974ce6
FC
1936 if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
1937
11343788 1938 switch (o->op_type) {
68dc0745 1939 case OP_UNDEF:
3280af22 1940 PL_modcount++;
5dc0d613 1941 return o;
5f05dabc 1942 case OP_STUB:
58bde88d 1943 if ((o->op_flags & OPf_PARENS) || PL_madskills)
5f05dabc
PP
1944 break;
1945 goto nomod;
a0d0e21e 1946 case OP_ENTERSUB:
f79aa60b 1947 if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
11343788
MB
1948 !(o->op_flags & OPf_STACKED)) {
1949 o->op_type = OP_RV2CV; /* entersub => rv2cv */
767eda44
FC
1950 /* Both ENTERSUB and RV2CV use this bit, but for different pur-
1951 poses, so we need it clear. */
e26df76a 1952 o->op_private &= ~1;
22c35a8c 1953 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 1954 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 1955 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
79072805
LW
1956 break;
1957 }
cd06dffe 1958 else { /* lvalue subroutine call */
777d9014
FC
1959 o->op_private |= OPpLVAL_INTRO
1960 |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
e6438c1a 1961 PL_modcount = RETURN_UNLIMITED_NUMBER;
4978d6d9 1962 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
d0887bf3 1963 /* Potential lvalue context: */
cd06dffe
GS
1964 o->op_private |= OPpENTERSUB_INARGS;
1965 break;
1966 }
1967 else { /* Compile-time error message: */
1968 OP *kid = cUNOPo->op_first;
1969 CV *cv;
cd06dffe 1970
3ea285d1
AL
1971 if (kid->op_type != OP_PUSHMARK) {
1972 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1973 Perl_croak(aTHX_
1974 "panic: unexpected lvalue entersub "
1975 "args: type/targ %ld:%"UVuf,
1976 (long)kid->op_type, (UV)kid->op_targ);
1977 kid = kLISTOP->op_first;
1978 }
cd06dffe
GS
1979 while (kid->op_sibling)
1980 kid = kid->op_sibling;
1981 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
cd06dffe
GS
1982 break; /* Postpone until runtime */
1983 }
b2ffa427 1984
cd06dffe
GS
1985 kid = kUNOP->op_first;
1986 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1987 kid = kUNOP->op_first;
b2ffa427 1988 if (kid->op_type == OP_NULL)
cd06dffe
GS
1989 Perl_croak(aTHX_
1990 "Unexpected constant lvalue entersub "
55140b79 1991 "entry via type/targ %ld:%"UVuf,
3d811634 1992 (long)kid->op_type, (UV)kid->op_targ);
cd06dffe 1993 if (kid->op_type != OP_GV) {
cd06dffe
GS
1994 break;
1995 }
b2ffa427 1996
638eceb6 1997 cv = GvCV(kGVOP_gv);
1c846c1f 1998 if (!cv)
da1dff94 1999 break;
cd06dffe
GS
2000 if (CvLVALUE(cv))
2001 break;
2002 }
2003 }
79072805
LW
2004 /* FALL THROUGH */
2005 default:
a0d0e21e 2006 nomod:
f5d552b4 2007 if (flags & OP_LVALUE_NO_CROAK) return NULL;
6fbb66d6 2008 /* grep, foreach, subcalls, refgen */
145b2bbb
FC
2009 if (type == OP_GREPSTART || type == OP_ENTERSUB
2010 || type == OP_REFGEN || type == OP_LEAVESUBLV)
a0d0e21e 2011 break;
cea2e8a9 2012 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
638bc118 2013 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
cd06dffe
GS
2014 ? "do block"
2015 : (o->op_type == OP_ENTERSUB
2016 ? "non-lvalue subroutine call"
53e06cf0 2017 : OP_DESC(o))),
22c35a8c 2018 type ? PL_op_desc[type] : "local"));
11343788 2019 return o;
79072805 2020
a0d0e21e
LW
2021 case OP_PREINC:
2022 case OP_PREDEC:
2023 case OP_POW:
2024 case OP_MULTIPLY:
2025 case OP_DIVIDE:
2026 case OP_MODULO:
2027 case OP_REPEAT:
2028 case OP_ADD:
2029 case OP_SUBTRACT:
2030 case OP_CONCAT:
2031 case OP_LEFT_SHIFT:
2032 case OP_RIGHT_SHIFT:
2033 case OP_BIT_AND:
2034 case OP_BIT_XOR:
2035 case OP_BIT_OR:
2036 case OP_I_MULTIPLY:
2037 case OP_I_DIVIDE:
2038 case OP_I_MODULO:
2039 case OP_I_ADD:
2040 case OP_I_SUBTRACT:
11343788 2041 if (!(o->op_flags & OPf_STACKED))
a0d0e21e 2042 goto nomod;
3280af22 2043 PL_modcount++;
a0d0e21e 2044 break;
b2ffa427 2045
79072805 2046 case OP_COND_EXPR:
ddeae0f1 2047 localize = 1;
11343788 2048 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
3ad73efd 2049 op_lvalue(kid, type);
79072805
LW
2050 break;
2051
2052 case OP_RV2AV:
2053 case OP_RV2HV:
11343788 2054 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
e6438c1a 2055 PL_modcount = RETURN_UNLIMITED_NUMBER;
11343788 2056 return o; /* Treat \(@foo) like ordinary list. */
748a9306
LW
2057 }
2058 /* FALL THROUGH */
79072805 2059 case OP_RV2GV:
5dc0d613 2060 if (scalar_mod_type(o, type))
3fe9a6f1 2061 goto nomod;
11343788 2062 ref(cUNOPo->op_first, o->op_type);
79072805 2063 /* FALL THROUGH */
79072805
LW
2064 case OP_ASLICE:
2065 case OP_HSLICE:
ddeae0f1 2066 localize = 1;
78f9721b
SM
2067 /* FALL THROUGH */
2068 case OP_AASSIGN:
631dbaa2
FC
2069 if (type == OP_LEAVESUBLV)
2070 o->op_private |= OPpMAYBE_LVSUB;
2071 /* FALL THROUGH */
93a17b20
LW
2072 case OP_NEXTSTATE:
2073 case OP_DBSTATE:
e6438c1a 2074 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2075 break;
28c5b5bc
RGS
2076 case OP_AV2ARYLEN:
2077 PL_hints |= HINT_BLOCK_SCOPE;
2078 if (type == OP_LEAVESUBLV)
2079 o->op_private |= OPpMAYBE_LVSUB;
2080 PL_modcount++;
2081 break;
463ee0b2 2082 case OP_RV2SV:
aeea060c 2083 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2084 localize = 1;
463ee0b2 2085 /* FALL THROUGH */
79072805 2086 case OP_GV:
3280af22 2087 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 2088 case OP_SASSIGN:
bf4b1e52
GS
2089 case OP_ANDASSIGN:
2090 case OP_ORASSIGN:
c963b151 2091 case OP_DORASSIGN:
ddeae0f1
DM
2092 PL_modcount++;
2093 break;
2094
8990e307 2095 case OP_AELEMFAST:
93bad3fd 2096 case OP_AELEMFAST_LEX:
6a077020 2097 localize = -1;
3280af22 2098 PL_modcount++;
8990e307
LW
2099 break;
2100
748a9306
LW
2101 case OP_PADAV:
2102 case OP_PADHV:
e6438c1a 2103 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB
2104 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2105 return o; /* Treat \(@foo) like ordinary list. */
2106 if (scalar_mod_type(o, type))
3fe9a6f1 2107 goto nomod;
78f9721b
SM
2108 if (type == OP_LEAVESUBLV)
2109 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW
2110 /* FALL THROUGH */
2111 case OP_PADSV:
3280af22 2112 PL_modcount++;
ddeae0f1 2113 if (!type) /* local() */
5ede95a0
BF
2114 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2115 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW
2116 break;
2117
748a9306 2118 case OP_PUSHMARK:
ddeae0f1 2119 localize = 0;
748a9306 2120 break;
b2ffa427 2121
69969c6f 2122 case OP_KEYS:
d8065907 2123 case OP_RKEYS:
fad4a2e4 2124 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2125 goto nomod;
5d82c453
GA
2126 goto lvalue_func;
2127 case OP_SUBSTR:
2128 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2129 goto nomod;
5f05dabc 2130 /* FALL THROUGH */
a0d0e21e 2131 case OP_POS:
463ee0b2 2132 case OP_VEC:
fad4a2e4 2133 lvalue_func:
78f9721b
SM
2134 if (type == OP_LEAVESUBLV)
2135 o->op_private |= OPpMAYBE_LVSUB;
11343788 2136 if (o->op_flags & OPf_KIDS)
3ad73efd 2137 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 2138 break;
a0d0e21e 2139
463ee0b2
LW
2140 case OP_AELEM:
2141 case OP_HELEM:
11343788 2142 ref(cBINOPo->op_first, o->op_type);
68dc0745 2143 if (type == OP_ENTERSUB &&
5dc0d613
MB
2144 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2145 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM
2146 if (type == OP_LEAVESUBLV)
2147 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2148 localize = 1;
3280af22 2149 PL_modcount++;
463ee0b2
LW
2150 break;
2151
2152 case OP_SCOPE:
2153 case OP_LEAVE:
2154 case OP_ENTER:
78f9721b 2155 case OP_LINESEQ:
ddeae0f1 2156 localize = 0;
11343788 2157 if (o->op_flags & OPf_KIDS)
3ad73efd 2158 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW
2159 break;
2160
2161 case OP_NULL:
ddeae0f1 2162 localize = 0;
638bc118
GS
2163 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2164 goto nomod;
2165 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2166 break;
11343788 2167 if (o->op_targ != OP_LIST) {
3ad73efd 2168 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW
2169 break;
2170 }
2171 /* FALL THROUGH */
463ee0b2 2172 case OP_LIST:
ddeae0f1 2173 localize = 0;
11343788 2174 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG
2175 /* elements might be in void context because the list is
2176 in scalar context or because they are attribute sub calls */
2177 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2178 op_lvalue(kid, type);
463ee0b2 2179 break;
78f9721b
SM
2180
2181 case OP_RETURN:
2182 if (type != OP_LEAVESUBLV)
2183 goto nomod;
3ad73efd 2184 break; /* op_lvalue()ing was handled by ck_return() */
1efec5ed
FC
2185
2186 case OP_COREARGS:
2187 return o;
463ee0b2 2188 }
58d95175 2189
8be1be90
AMS
2190 /* [20011101.069] File test operators interpret OPf_REF to mean that
2191 their argument is a filehandle; thus \stat(".") should not set
2192 it. AMS 20011102 */
2193 if (type == OP_REFGEN &&
ef69c8fc 2194 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS
2195 return o;
2196
2197 if (type != OP_LEAVESUBLV)
2198 o->op_flags |= OPf_MOD;
2199
2200 if (type == OP_AASSIGN || type == OP_SASSIGN)
2201 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM
2202 else if (!type) { /* local() */
2203 switch (localize) {
2204 case 1:
2205 o->op_private |= OPpLVAL_INTRO;
2206 o->op_flags &= ~OPf_SPECIAL;
2207 PL_hints |= HINT_BLOCK_SCOPE;
2208 break;
2209 case 0:
2210 break;
2211 case -1:
a2a5de95
NC
2212 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2213 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2214 }
463ee0b2 2215 }
8be1be90
AMS
2216 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2217 && type != OP_LEAVESUBLV)
2218 o->op_flags |= OPf_REF;
11343788 2219 return o;
463ee0b2
LW
2220}
2221
864dbfa3 2222STATIC bool
5f66b61c 2223S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1
PP
2224{
2225 switch (type) {
32a60974 2226 case OP_POS:
3fe9a6f1 2227 case OP_SASSIGN:
1efec5ed 2228 if (o && o->op_type == OP_RV2GV)
3fe9a6f1
PP
2229 return FALSE;
2230 /* FALL THROUGH */
2231 case OP_PREINC:
2232 case OP_PREDEC:
2233 case OP_POSTINC:
2234 case OP_POSTDEC:
2235 case OP_I_PREINC:
2236 case OP_I_PREDEC:
2237 case OP_I_POSTINC:
2238 case OP_I_POSTDEC:
2239 case OP_POW:
2240 case OP_MULTIPLY:
2241 case OP_DIVIDE:
2242 case OP_MODULO:
2243 case OP_REPEAT:
2244 case OP_ADD:
2245 case OP_SUBTRACT:
2246 case OP_I_MULTIPLY:
2247 case OP_I_DIVIDE:
2248 case OP_I_MODULO:
2249 case OP_I_ADD:
2250 case OP_I_SUBTRACT:
2251 case OP_LEFT_SHIFT:
2252 case OP_RIGHT_SHIFT:
2253 case OP_BIT_AND:
2254 case OP_BIT_XOR:
2255 case OP_BIT_OR:
2256 case OP_CONCAT:
2257 case OP_SUBST:
2258 case OP_TRANS:
bb16bae8 2259 case OP_TRANSR:
49e9fbe6
GS
2260 case OP_READ:
2261 case OP_SYSREAD:
2262 case OP_RECV:
bf4b1e52
GS
2263 case OP_ANDASSIGN:
2264 case OP_ORASSIGN:
410d09fe 2265 case OP_DORASSIGN:
3fe9a6f1
PP
2266 return TRUE;
2267 default:
2268 return FALSE;
2269 }
2270}
2271
35cd451c 2272STATIC bool
5f66b61c 2273S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2274{
7918f24d
NC
2275 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2276
35cd451c
GS
2277 switch (o->op_type) {
2278 case OP_PIPE_OP:
2279 case OP_SOCKPAIR:
504618e9 2280 if (numargs == 2)
35cd451c
GS
2281 return TRUE;
2282 /* FALL THROUGH */
2283 case OP_SYSOPEN:
2284 case OP_OPEN:
ded8aa31 2285 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS
2286 case OP_SOCKET:
2287 case OP_OPEN_DIR:
2288 case OP_ACCEPT:
504618e9 2289 if (numargs == 1)
35cd451c 2290 return TRUE;
5f66b61c 2291 /* FALLTHROUGH */
35cd451c
GS
2292 default:
2293 return FALSE;
2294 }
2295}
2296
0d86688d
NC
2297static OP *
2298S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2299{
11343788 2300 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2301 OP *kid;
11343788 2302 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW
2303 ref(kid, type);
2304 }
11343788 2305 return o;
463ee0b2
LW
2306}
2307
2308OP *
e4c5ccf3 2309Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2310{
27da23d5 2311 dVAR;
463ee0b2 2312 OP *kid;
463ee0b2 2313
7918f24d
NC
2314 PERL_ARGS_ASSERT_DOREF;
2315
13765c85 2316 if (!o || (PL_parser && PL_parser->error_count))
11343788 2317 return o;
463ee0b2 2318
11343788 2319 switch (o->op_type) {
a0d0e21e 2320 case OP_ENTERSUB:
f4df43b5 2321 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB
2322 !(o->op_flags & OPf_STACKED)) {
2323 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2324 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2325 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2326 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2327 o->op_flags |= OPf_SPECIAL;
e26df76a 2328 o->op_private &= ~1;
8990e307 2329 }
767eda44 2330 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG
2331 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2332 : type == OP_RV2HV ? OPpDEREF_HV
2333 : OPpDEREF_SV);
767eda44
FC
2334 o->op_flags |= OPf_MOD;
2335 }
2336
8990e307 2337 break;
aeea060c 2338
463ee0b2 2339 case OP_COND_EXPR:
11343788 2340 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2341 doref(kid, type, set_op_ref);
463ee0b2 2342 break;
8990e307 2343 case OP_RV2SV:
35cd451c
GS
2344 if (type == OP_DEFINED)
2345 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2346 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW
2347 /* FALL THROUGH */
2348 case OP_PADSV:
5f05dabc 2349 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
2350 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2351 : type == OP_RV2HV ? OPpDEREF_HV
2352 : OPpDEREF_SV);
11343788 2353 o->op_flags |= OPf_MOD;
a0d0e21e 2354 }
8990e307 2355 break;
1c846c1f 2356
463ee0b2
LW
2357 case OP_RV2AV:
2358 case OP_RV2HV:
e4c5ccf3
RH
2359 if (set_op_ref)
2360 o->op_flags |= OPf_REF;
8990e307 2361 /* FALL THROUGH */
463ee0b2 2362 case OP_RV2GV:
35cd451c
GS
2363 if (type == OP_DEFINED)
2364 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2365 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2366 break;
8990e307 2367
463ee0b2
LW
2368 case OP_PADAV:
2369 case OP_PADHV:
e4c5ccf3
RH
2370 if (set_op_ref)
2371 o->op_flags |= OPf_REF;
79072805 2372 break;
aeea060c 2373
8990e307 2374 case OP_SCALAR:
79072805 2375 case OP_NULL:
518618af 2376 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 2377 break;
e4c5ccf3 2378 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW
2379 break;
2380 case OP_AELEM:
2381 case OP_HELEM:
e4c5ccf3 2382 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2383 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB
2384 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2385 : type == OP_RV2HV ? OPpDEREF_HV
2386 : OPpDEREF_SV);
11343788 2387 o->op_flags |= OPf_MOD;
8990e307 2388 }
79072805
LW
2389 break;
2390
463ee0b2 2391 case OP_SCOPE:
79072805 2392 case OP_LEAVE:
e4c5ccf3
RH
2393 set_op_ref = FALSE;
2394 /* FALL THROUGH */
79072805 2395 case OP_ENTER:
8990e307 2396 case OP_LIST:
11343788 2397 if (!(o->op_flags & OPf_KIDS))
79072805 2398 break;
e4c5ccf3 2399 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2400 break;
a0d0e21e
LW
2401 default:
2402 break;
79072805 2403 }
11343788 2404 return scalar(o);
8990e307 2405
79072805
LW
2406}
2407
09bef843
SB
2408STATIC OP *
2409S_dup_attrlist(pTHX_ OP *o)
2410{
97aff369 2411 dVAR;
0bd48802 2412 OP *rop;
09bef843 2413
7918f24d
NC
2414 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2415
09bef843
SB
2416 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2417 * where the first kid is OP_PUSHMARK and the remaining ones
2418 * are OP_CONST. We need to push the OP_CONST values.
2419 */
2420 if (o->op_type == OP_CONST)
b37c2d43 2421 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC
2422#ifdef PERL_MAD
2423 else if (o->op_type == OP_NULL)
1d866c12 2424 rop = NULL;
eb8433b7 2425#endif
09bef843
SB
2426 else {
2427 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2428 rop = NULL;
09bef843
SB
2429 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2430 if (o->op_type == OP_CONST)
2fcb4757 2431 rop = op_append_elem(OP_LIST, rop,
09bef843 2432 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2433 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB
2434 }
2435 }
2436 return rop;
2437}
2438
2439STATIC void
ad0dc73b 2440S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 2441{
27da23d5 2442 dVAR;
ad0dc73b 2443 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
09bef843 2444
7918f24d
NC
2445 PERL_ARGS_ASSERT_APPLY_ATTRS;
2446
09bef843
SB
2447 /* fake up C<use attributes $pkg,$rv,@attrs> */
2448 ENTER; /* need to protect against side-effects of 'use' */
e4783991 2449
09bef843 2450#define ATTRSMODULE "attributes"
95f0a2f1
SB
2451#define ATTRSMODULE_PM "attributes.pm"
2452
ad0dc73b 2453 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL
2454 newSVpvs(ATTRSMODULE),
2455 NULL,
2fcb4757 2456 op_prepend_elem(OP_LIST,
95f0a2f1 2457 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2458 op_prepend_elem(OP_LIST,
95f0a2f1
SB
2459 newSVOP(OP_CONST, 0,
2460 newRV(target)),
2461 dup_attrlist(attrs))));
09bef843
SB
2462 LEAVE;
2463}
2464
95f0a2f1
SB
2465STATIC void
2466S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2467{
97aff369 2468 dVAR;
95f0a2f1 2469 OP *pack, *imop, *arg;
ad0dc73b 2470 SV *meth, *stashsv, **svp;
95f0a2f1 2471
7918f24d
NC
2472 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2473
95f0a2f1
SB
2474 if (!attrs)
2475 return;
2476
2477 assert(target->op_type == OP_PADSV ||
2478 target->op_type == OP_PADHV ||
2479 target->op_type == OP_PADAV);
2480
2481 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC
2482 ENTER; /* need to protect against side-effects of 'use' */
2483 /* Don't force the C<use> if we don't need it. */
2484 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2485 if (svp && *svp != &PL_sv_undef)
2486 NOOP; /* already in %INC */
2487 else
2488 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2489 newSVpvs(ATTRSMODULE), NULL);
2490 LEAVE;
95f0a2f1
SB
2491
2492 /* Need package name for method call. */
6136c704 2493 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB
2494
2495 /* Build up the real arg-list. */
5aaec2b4
NC
2496 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2497
95f0a2f1
SB
2498 arg = newOP(OP_PADSV, 0);
2499 arg->op_targ = target->op_targ;
2fcb4757 2500 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2501 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2502 op_prepend_elem(OP_LIST,
95f0a2f1 2503 newUNOP(OP_REFGEN, 0,
3ad73efd 2504 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB
2505 dup_attrlist(attrs)));
2506
2507 /* Fake up a method call to import */
18916d0d 2508 meth = newSVpvs_share("import");
95f0a2f1 2509 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z
2510 op_append_elem(OP_LIST,
2511 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2512 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB
2513
2514 /* Combine the ops. */
2fcb4757 2515 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB
2516}
2517
2518/*
2519=notfor apidoc apply_attrs_string
2520
2521Attempts to apply a list of attributes specified by the C<attrstr> and
2522C<len> arguments to the subroutine identified by the C<cv> argument which
2523is expected to be associated with the package identified by the C<stashpv>
2524argument (see L<attributes>). It gets this wrong, though, in that it
2525does not correctly identify the boundaries of the individual attribute
2526specifications within C<attrstr>. This is not really intended for the
2527public API, but has to be listed here for systems such as AIX which
2528need an explicit export list for symbols. (It's called from XS code
2529in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2530to respect attribute syntax properly would be welcome.
2531
2532=cut
2533*/
2534
be3174d2 2535void
6867be6d
AL
2536Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2537 const char *attrstr, STRLEN len)
be3174d2 2538{
5f66b61c 2539 OP *attrs = NULL;
be3174d2 2540
7918f24d
NC
2541 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2542
be3174d2
GS
2543 if (!len) {
2544 len = strlen(attrstr);
2545 }
2546
2547 while (len) {
2548 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2549 if (len) {
890ce7af 2550 const char * const sstr = attrstr;
be3174d2 2551 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2552 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS
2553 newSVOP(OP_CONST, 0,
2554 newSVpvn(sstr, attrstr-sstr)));
2555 }
2556 }
2557
2558 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2559 newSVpvs(ATTRSMODULE),
2fcb4757 2560 NULL, op_prepend_elem(OP_LIST,
be3174d2 2561 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2562 op_prepend_elem(OP_LIST,
be3174d2 2563 newSVOP(OP_CONST, 0,
ad64d0ec 2564 newRV(MUTABLE_SV(cv))),
be3174d2
GS
2565 attrs)));
2566}
2567
09bef843 2568STATIC OP *
95f0a2f1 2569S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2570{
97aff369 2571 dVAR;
93a17b20 2572 I32 type;
a1fba7eb 2573 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2574
7918f24d
NC
2575 PERL_ARGS_ASSERT_MY_KID;
2576
13765c85 2577 if (!o || (PL_parser && PL_parser->error_count))
11343788 2578 return o;
93a17b20 2579
bc61e325 2580 type = o->op_type;
eb8433b7
NC
2581 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2582 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2583 return o;
2584 }
2585
93a17b20 2586 if (type == OP_LIST) {
6867be6d 2587 OP *kid;
11343788 2588 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2589 my_kid(kid, attrs, imopsp);
0865059d 2590 return o;
8b8c1fb9 2591 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 2592 return o;
77ca0c92
LW
2593 } else if (type == OP_RV2SV || /* "our" declaration */
2594 type == OP_RV2AV ||
2595 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2596 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2597 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2598 OP_DESC(o),
12bd6ede
DM
2599 PL_parser->in_my == KEY_our
2600 ? "our"
2601 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2602 } else if (attrs) {
551405c4 2603 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM
2604 PL_parser->in_my = FALSE;
2605 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS
2606 apply_attrs(GvSTASH(gv),
2607 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC
2608 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2609 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
ad0dc73b 2610 attrs);
1ce0b88c 2611 }
192587c2 2612 o->op_private |= OPpOUR_INTRO;
77ca0c92 2613 return o;
95f0a2f1
SB
2614 }
2615 else if (type != OP_PADSV &&
93a17b20
LW
2616 type != OP_PADAV &&
2617 type != OP_PADHV &&
2618 type != OP_PUSHMARK)
2619 {
eb64745e 2620 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2621 OP_DESC(o),
12bd6ede
DM
2622 PL_parser->in_my == KEY_our
2623 ? "our"
2624 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2625 return o;
93a17b20 2626 }
09bef843
SB
2627 else if (attrs && type != OP_PUSHMARK) {
2628 HV *stash;
09bef843 2629
12bd6ede
DM
2630 PL_parser->in_my = FALSE;
2631 PL_parser->in_my_stash = NULL;
eb64745e 2632
09bef843 2633 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM
2634 stash = PAD_COMPNAME_TYPE(o->op_targ);
2635 if (!stash)
09bef843 2636 stash = PL_curstash;
95f0a2f1 2637 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2638 }
11343788
MB
2639 o->op_flags |= OPf_MOD;
2640 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2641 if (stately)
952306ac 2642 o->op_private |= OPpPAD_STATE;
11343788 2643 return o;
93a17b20
LW
2644}
2645
2646OP *
09bef843
SB
2647Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2648{
97aff369 2649 dVAR;
0bd48802 2650 OP *rops;
95f0a2f1
SB
2651 int maybe_scalar = 0;
2652
7918f24d
NC
2653 PERL_ARGS_ASSERT_MY_ATTRS;
2654
d2be0de5 2655/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2656 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2657#if 0
09bef843
SB
2658 if (o->op_flags & OPf_PARENS)
2659 list(o);
95f0a2f1
SB
2660 else
2661 maybe_scalar = 1;
d2be0de5
YST
2662#else
2663 maybe_scalar = 1;
2664#endif
09bef843
SB
2665 if (attrs)
2666 SAVEFREEOP(attrs);
5f66b61c 2667 rops = NULL;
95f0a2f1
SB
2668 o = my_kid(o, attrs, &rops);
2669 if (rops) {
2670 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2671 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB
2672 o->op_private |= OPpLVAL_INTRO;
2673 }
f5d1ed10
FC
2674 else {
2675 /* The listop in rops might have a pushmark at the beginning,
2676 which will mess up list assignment. */
2677 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2678 if (rops->op_type == OP_LIST &&
2679 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2680 {
2681 OP * const pushmark = lrops->op_first;
2682 lrops->op_first = pushmark->op_sibling;
2683 op_free(pushmark);
2684 }
2fcb4757 2685 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2686 }
95f0a2f1 2687 }
12bd6ede
DM
2688 PL_parser->in_my = FALSE;
2689 PL_parser->in_my_stash = NULL;
eb64745e 2690 return o;
09bef843
SB
2691}
2692
2693OP *
864dbfa3 2694Perl_sawparens(pTHX_ OP *o)
79072805 2695{
96a5add6 2696 PERL_UNUSED_CONTEXT;
79072805
LW
2697 if (o)
2698 o->op_flags |= OPf_PARENS;
2699 return o;
2700}
2701
2702OP *
864dbfa3 2703Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2704{
11343788 2705 OP *o;
59f00321 2706 bool ismatchop = 0;
1496a290
AL
2707 const OPCODE ltype = left->op_type;
2708 const OPCODE rtype = right->op_type;
79072805 2709
7918f24d
NC
2710 PERL_ARGS_ASSERT_BIND_MATCH;
2711
1496a290
AL
2712 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2713 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2714 {
1496a290 2715 const char * const desc
bb16bae8
FC
2716 = PL_op_desc[(
2717 rtype == OP_SUBST || rtype == OP_TRANS
2718 || rtype == OP_TRANSR
2719 )
666ea192 2720 ? (int)rtype : OP_MATCH];
c6771ab6
FC
2721 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2722 GV *gv;
2723 SV * const name =
2724 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2725 ? cUNOPx(left)->op_first->op_type == OP_GV
2726 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2727 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2728 : NULL
ba510004
FC
2729 : varname(
2730 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2731 );
c6771ab6
FC
2732 if (name)
2733 Perl_warner(aTHX_ packWARN(WARN_MISC),
2734 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2735 desc, name, name);
2736 else {
2737 const char * const sample = (isary
666ea192 2738 ? "@array" : "%hash");
c6771ab6 2739 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2740 "Applying %s to %s will act on scalar(%s)",
599cee73 2741 desc, sample, sample);
c6771ab6 2742 }
2ae324a7
PP
2743 }
2744
1496a290 2745 if (rtype == OP_CONST &&
5cc9e5c9
RH
2746 cSVOPx(right)->op_private & OPpCONST_BARE &&
2747 cSVOPx(right)->op_private & OPpCONST_STRICT)
2748 {
2749 no_bareword_allowed(right);
2750 }
2751
bb16bae8 2752 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC
2753 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2754 type == OP_NOT)
2755 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC
2756 if (rtype == OP_TRANSR && type == OP_NOT)
2757 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2758
2474a784
FC
2759 ismatchop = (rtype == OP_MATCH ||
2760 rtype == OP_SUBST ||
bb16bae8 2761 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2762 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS
2763 if (ismatchop && right->op_private & OPpTARGET_MY) {
2764 right->op_targ = 0;
2765 right->op_private &= ~OPpTARGET_MY;
2766 }
2767 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL
2768 OP *newleft;
2769
79072805 2770 right->op_flags |= OPf_STACKED;
bb16bae8 2771 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2772 ! (rtype == OP_TRANS &&
4f4d7508
DC
2773 right->op_private & OPpTRANS_IDENTICAL) &&
2774 ! (rtype == OP_SUBST &&
2775 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2776 newleft = op_lvalue(left, rtype);
1496a290
AL
2777 else
2778 newleft = left;
bb16bae8 2779 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2780 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2781 else
2fcb4757 2782 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2783 if (type == OP_NOT)
11343788
MB
2784 return newUNOP(OP_NOT, 0, scalar(o));
2785 return o;
79072805
LW
2786 }
2787 else
2788 return bind_match(type, left,
d63c20f2 2789 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW
2790}
2791
2792OP *
864dbfa3 2793Perl_invert(pTHX_ OP *o)
79072805 2794{
11343788 2795 if (!o)
1d866c12 2796 return NULL;
11343788 2797 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW
2798}
2799
3ad73efd
Z
2800/*
2801=for apidoc Amx|OP *|op_scope|OP *o
2802
2803Wraps up an op tree with some additional ops so that at runtime a dynamic
2804scope will be created. The original ops run in the new dynamic scope,
2805and then, provided that they exit normally, the scope will be unwound.
2806The additional ops used to create and unwind the dynamic scope will
2807normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2808instead if the ops are simple enough to not need the full dynamic scope
2809structure.
2810
2811=cut
2812*/
2813
79072805 2814OP *
3ad73efd 2815Perl_op_scope(pTHX_ OP *o)
79072805 2816{
27da23d5 2817 dVAR;
79072805 2818 if (o) {
284167a5 2819 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2fcb4757 2820 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2821 o->op_type = OP_LEAVE;
22c35a8c 2822 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2823 }
fdb22418
HS
2824 else if (o->op_type == OP_LINESEQ) {
2825 OP *kid;
2826 o->op_type = OP_SCOPE;
2827 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2828 kid = ((LISTOP*)o)->op_first;
59110972 2829 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2830 op_null(kid);
59110972
RH
2831
2832 /* The following deals with things like 'do {1 for 1}' */
2833 kid = kid->op_sibling;
2834 if (kid &&
2835 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2836 op_null(kid);
2837 }
463ee0b2 2838 }
fdb22418 2839 else
5f66b61c 2840 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW
2841 }
2842 return o;
2843}
1930840b 2844
705fe0e5
FC
2845OP *
2846Perl_op_unscope(pTHX_ OP *o)
2847{
2848 if (o && o->op_type == OP_LINESEQ) {
2849 OP *kid = cLISTOPo->op_first;
2850 for(; kid; kid = kid->op_sibling)
2851 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2852 op_null(kid);
2853 }
2854 return o;
2855}
2856
a0d0e21e 2857int
864dbfa3 2858Perl_block_start(pTHX_ int full)
79072805 2859{
97aff369 2860 dVAR;
73d840c0 2861 const int retval = PL_savestack_ix;
1930840b 2862
dd2155a4 2863 pad_block_start(full);
b3ac6de7 2864 SAVEHINTS();
3280af22 2865 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2866 SAVECOMPILEWARNINGS();
72dc9ed5 2867 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2868
a88d97bf 2869 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2870
a0d0e21e
LW
2871 return retval;
2872}
2873
2874OP*
864dbfa3 2875Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2876{
97aff369 2877 dVAR;
6867be6d 2878 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b 2879 OP* retval = scalarseq(seq);
6d5c2147 2880 OP *o;
1930840b 2881
a88d97bf 2882 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2883
e9818f4e 2884 LEAVE_SCOPE(floor);
623e6609 2885 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2886 if (needblockscope)
3280af22 2887 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
6d5c2147
FC
2888 o = pad_leavemy();
2889
2890 if (o) {
2891 /* pad_leavemy has created a sequence of introcv ops for all my
2892 subs declared in the block. We have to replicate that list with
2893 clonecv ops, to deal with this situation:
2894
2895 sub {
2896 my sub s1;
2897 my sub s2;
2898 sub s1 { state sub foo { \&s2 } }
2899 }->()
2900
2901 Originally, I was going to have introcv clone the CV and turn
2902 off the stale flag. Since &s1 is declared before &s2, the
2903 introcv op for &s1 is executed (on sub entry) before the one for
2904 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
2905 cloned, since it is a state sub) closes over &s2 and expects
2906 to see it in its outer CV’s pad. If the introcv op clones &s1,
2907 then &s2 is still marked stale. Since &s1 is not active, and
2908 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
2909 ble will not stay shared’ warning. Because it is the same stub
2910 that will be used when the introcv op for &s2 is executed, clos-
2911 ing over it is safe. Hence, we have to turn off the stale flag
2912 on all lexical subs in the block before we clone any of them.
2913 Hence, having introcv clone the sub cannot work. So we create a
2914 list of ops like this:
2915
2916 lineseq
2917 |
2918 +-- introcv
2919 |
2920 +-- introcv
2921 |
2922 +-- introcv
2923 |
2924 .
2925 .
2926 .
2927 |
2928 +-- clonecv
2929 |
2930 +-- clonecv
2931 |
2932 +-- clonecv
2933 |
2934 .
2935 .
2936 .
2937 */
2938 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
2939 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
2940 for (;; kid = kid->op_sibling) {
2941 OP *newkid = newOP(OP_CLONECV, 0);
2942 newkid->op_targ = kid->op_targ;
2943 o = op_append_elem(OP_LINESEQ, o, newkid);
2944 if (kid == last) break;
2945 }
2946 retval = op_prepend_elem(OP_LINESEQ, o, retval);
2947 }
1930840b 2948
a88d97bf 2949 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2950
a0d0e21e
LW
2951 return retval;
2952}
2953
fd85fad2
BM
2954/*
2955=head1 Compile-time scope hooks
2956
3e4ddde5 2957=for apidoc Aox||blockhook_register
fd85fad2
BM
2958
2959Register a set of hooks to be called when the Perl lexical scope changes
2960at compile time. See L<perlguts/"Compile-time scope hooks">.
2961
2962=cut
2963*/
2964
bb6c22e7
BM
2965void
2966Perl_blockhook_register(pTHX_ BHK *hk)
2967{
2968 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2969
2970 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2971}
2972
76e3520e 2973STATIC OP *
cea2e8a9 2974S_newDEFSVOP(pTHX)
54b9620d 2975{
97aff369 2976 dVAR;
cc76b5cc 2977 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 2978 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS
2979 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2980 }
2981 else {
551405c4 2982 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS
2983 o->op_targ = offset;
2984 return o;
2985 }
54b9620d
MB
2986}
2987
a0d0e21e 2988void
864dbfa3 2989Perl_newPROG(pTHX_ OP *o)
a0d0e21e 2990{
97aff369 2991 dVAR;
7918f24d
NC
2992
2993 PERL_ARGS_ASSERT_NEWPROG;
2994
3280af22 2995 if (PL_in_eval) {
86a64801 2996 PERL_CONTEXT *cx;
63429d50 2997 I32 i;
b295d113
TH
2998 if (PL_eval_root)
2999 return;
faef0170
HS
3000 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3001 ((PL_in_eval & EVAL_KEEPERR)
3002 ? OPf_SPECIAL : 0), o);
86a64801
GG
3003
3004 cx = &cxstack[cxstack_ix];
3005 assert(CxTYPE(cx) == CXt_EVAL);
3006
3007 if ((cx->blk_gimme & G_WANT) == G_VOID)
3008 scalarvoid(PL_eval_root);
3009 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3010 list(PL_eval_root);
3011 else
3012 scalar(PL_eval_root);
3013
5983a79d 3014 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS
3015 PL_eval_root->op_private |= OPpREFCOUNTED;
3016 OpREFCNT_set(PL_eval_root, 1);
3280af22 3017 PL_eval_root->op_next = 0;
63429d50
FC
3018 i = PL_savestack_ix;
3019 SAVEFREEOP(o);
3020 ENTER;
a2efc822 3021 CALL_PEEP(PL_eval_start);
86a64801 3022 finalize_optree(PL_eval_root);
63429d50
FC
3023 LEAVE;
3024 PL_savestack_ix = i;
a0d0e21e
LW
3025 }
3026 else {
6be89cf9 3027 if (o->op_type == OP_STUB) {
22e660b4
NC
3028 /* This block is entered if nothing is compiled for the main
3029 program. This will be the case for an genuinely empty main
3030 program, or one which only has BEGIN blocks etc, so already
3031 run and freed.
3032
3033 Historically (5.000) the guard above was !o. However, commit
3034 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3035 c71fccf11fde0068, changed perly.y so that newPROG() is now
3036 called with the output of block_end(), which returns a new
3037 OP_STUB for the case of an empty optree. ByteLoader (and
3038 maybe other things) also take this path, because they set up
3039 PL_main_start and PL_main_root directly, without generating an
3040 optree.
8b31d4e4
NC
3041
3042 If the parsing the main program aborts (due to parse errors,
3043 or due to BEGIN or similar calling exit), then newPROG()
3044 isn't even called, and hence this code path and its cleanups
3045 are skipped. This shouldn't make a make a difference:
3046 * a non-zero return from perl_parse is a failure, and
3047 perl_destruct() should be called immediately.
3048 * however, if exit(0) is called during the parse, then
3049 perl_parse() returns 0, and perl_run() is called. As
3050 PL_main_start will be NULL, perl_run() will return
3051 promptly, and the exit code will remain 0.
22e660b4
NC
3052 */
3053
6be89cf9
AE
3054 PL_comppad_name = 0;
3055 PL_compcv = 0;
d2c837a0 3056 S_op_destroy(aTHX_ o);
a0d0e21e 3057 return;
6be89cf9 3058 }
3ad73efd 3059 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS
3060 PL_curcop = &PL_compiling;
3061 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS
3062 PL_main_root->op_private |= OPpREFCOUNTED;
3063 OpREFCNT_set(PL_main_root, 1);
3280af22 3064 PL_main_root->op_next = 0;
a2efc822 3065 CALL_PEEP(PL_main_start);
d164302a 3066 finalize_optree(PL_main_root);
8be227ab 3067 cv_forget_slab(PL_compcv);
3280af22 3068 PL_compcv = 0;
3841441e 3069
4fdae800 3070 /* Register with debugger */
84902520 3071 if (PERLDB_INTER) {
b96d8cd9 3072 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS
3073 if (cv) {
3074 dSP;
924508f0 3075 PUSHMARK(SP);
ad64d0ec 3076 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 3077 PUTBACK;
ad64d0ec 3078 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS
3079 }
3080 }
79072805 3081 }
79072805
LW
3082}
3083
3084OP *
864dbfa3 3085Perl_localize(pTHX_ OP *o, I32 lex)
79072805 3086{
97aff369 3087 dVAR;
7918f24d
NC
3088
3089 PERL_ARGS_ASSERT_LOCALIZE;
3090
79072805 3091 if (o->op_flags & OPf_PARENS)
d2be0de5
YST
3092/* [perl #17376]: this appears to be premature, and results in code such as
3093 C< our(%x); > executing in list mode rather than void mode */
3094#if 0
79072805 3095 list(o);
d2be0de5 3096#else
6f207bd3 3097 NOOP;
d2be0de5 3098#endif
8990e307 3099 else {
f06b5848
DM
3100 if ( PL_parser->bufptr > PL_parser->oldbufptr
3101 && PL_parser->bufptr[-1] == ','
041457d9 3102 && ckWARN(WARN_PARENTHESIS))
64420d0d 3103 {
f06b5848 3104 char *s = PL_parser->bufptr;
bac662ee 3105 bool sigil = FALSE;
64420d0d 3106
8473848f 3107 /* some heuristics to detect a potential error */
bac662ee 3108 while (*s && (strchr(", \t\n", *s)))
64420d0d 3109 s++;
8473848f 3110
bac662ee
ST
3111 while (1) {
3112 if (*s && strchr("@$%*", *s) && *++s
0eb30aeb 3113 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
bac662ee
ST
3114 s++;
3115 sigil = TRUE;
0eb30aeb 3116 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
bac662ee
ST
3117 s++;
3118 while (*s && (strchr(", \t\n", *s)))
3119 s++;
3120 }
3121 else
3122 break;
3123 }
3124 if (sigil && (*s == ';' || *s == '=')) {
3125 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 3126 "Parentheses missing around \"%s\" list",
12bd6ede
DM
3127 lex
3128 ? (PL_parser->in_my == KEY_our
3129 ? "our"
3130 : PL_parser->in_my == KEY_state
3131 ? "state"
3132 : "my")
3133 : "local");
8473848f 3134 }
8990e307
LW
3135 }
3136 }
93a17b20 3137 if (lex)
eb64745e 3138 o = my(o);
93a17b20 3139 else
3ad73efd 3140 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM
3141 PL_parser->in_my = FALSE;
3142 PL_parser->in_my_stash = NULL;
eb64745e 3143 return o;
79072805
LW
3144}
3145
3146OP *
864dbfa3 3147Perl_jmaybe(pTHX_ OP *o)
79072805 3148{
7918f24d
NC
3149 PERL_ARGS_ASSERT_JMAYBE;
3150
79072805 3151 if (o->op_type == OP_LIST) {
fafc274c 3152 OP * const o2
d4c19fe8 3153 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 3154 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW
3155 }
3156 return o;
3157}
3158
985b9e54
GG
3159PERL_STATIC_INLINE OP *
3160S_op_std_init(pTHX_ OP *o)
3161{
3162 I32 type = o->op_type;
3163
3164 PERL_ARGS_ASSERT_OP_STD_INIT;
3165
3166 if (PL_opargs[type] & OA_RETSCALAR)
3167 scalar(o);
3168 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3169 o->op_targ = pad_alloc(type, SVs_PADTMP);
3170
3171 return o;
3172}
3173
3174PERL_STATIC_INLINE OP *
3175S_op_integerize(pTHX_ OP *o)
3176{
3177 I32 type = o->op_type;
3178
3179 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3180
077da62f
FC
3181 /* integerize op. */
3182 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
985b9e54 3183 {
f5f19483 3184 dVAR;
985b9e54
GG
3185 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3186 }
3187
3188 if (type == OP_NEGATE)
3189 /* XXX might want a ck_negate() for this */
3190 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3191
3192 return o;
3193}
3194
1f676739 3195static OP *
5aaab254 3196S_fold_constants(pTHX_ OP *o)
79072805 3197{
27da23d5 3198 dVAR;
eb578fdb 3199 OP * VOL curop;
eb8433b7 3200 OP *newop;
8ea43dc8 3201 VOL I32 type = o->op_type;
e3cbe32f 3202 SV * VOL sv = NULL;
b7f7fd0b
NC
3203 int ret = 0;
3204 I32 oldscope;
3205 OP *old_next;
5f2d9966
DM
3206 SV * const oldwarnhook = PL_warnhook;
3207 SV * const olddiehook = PL_diehook;
c427f4d2 3208 COP not_compiling;
b7f7fd0b 3209 dJMPENV;
79072805 3210
7918f24d
NC
3211 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3212
22c35a8c 3213 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW
3214 goto nope;
3215
de939608 3216 switch (type) {
de939608
CS
3217 case OP_UCFIRST:
3218 case OP_LCFIRST:
3219 case OP_UC:
3220 case OP_LC:
7ccde120 3221 case OP_FC:
69dcf70c
MB
3222 case OP_SLT:
3223 case OP_SGT:
3224 case OP_SLE:
3225 case OP_SGE:
3226 case OP_SCMP:
b3fd6149 3227 case OP_SPRINTF:
2de3dbcc 3228 /* XXX what about the numeric ops? */
82ad65bb 3229 if (IN_LOCALE_COMPILETIME)
de939608 3230 goto nope;
553e7bb0 3231 break;
dd9a6ccf
FC
3232 case OP_PACK:
3233 if (!cLISTOPo->op_first->op_sibling
3234 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3235 goto nope;
3236 {
3237 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3238 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3239 {
3240 const char *s = SvPVX_const(sv);
3241 while (s < SvEND(sv)) {
3242 if (*s == 'p' || *s == 'P') goto nope;
3243 s++;
3244 }
3245 }
3246 }
3247 break;
baed7faa
FC
3248 case OP_REPEAT:
3249 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
de939608
CS
3250 }
3251
13765c85 3252 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
3253 goto nope; /* Don't try to run w/ errors */
3254
79072805 3255 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL
3256 const OPCODE type = curop->op_type;
3257 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3258 type != OP_LIST &&
3259 type != OP_SCALAR &&
3260 type != OP_NULL &&
3261 type != OP_PUSHMARK)
7a52d87a 3262 {
79072805
LW
3263 goto nope;
3264 }
3265 }
3266
3267 curop = LINKLIST(o);
b7f7fd0b 3268 old_next = o->op_next;
79072805 3269 o->op_next = 0;
533c011a 3270 PL_op = curop;
b7f7fd0b
NC
3271
3272 oldscope = PL_scopestack_ix;
edb2152a 3273 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3274
c427f4d2
NC
3275 /* Verify that we don't need to save it: */
3276 assert(PL_curcop == &PL_compiling);
3277 StructCopy(&PL_compiling, &not_compiling, COP);
3278 PL_curcop = &not_compiling;
3279 /* The above ensures that we run with all the correct hints of the
3280 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3281 assert(IN_PERL_RUNTIME);
5f2d9966
DM
3282 PL_warnhook = PERL_WARNHOOK_FATAL;
3283 PL_diehook = NULL;
b7f7fd0b
NC
3284 JMPENV_PUSH(ret);
3285
3286 switch (ret) {
3287 case 0:
3288 CALLRUNOPS(aTHX);
3289 sv = *(PL_stack_sp--);
523a0f0c
NC
3290 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3291#ifdef PERL_MAD
3292 /* Can't simply swipe the SV from the pad, because that relies on
3293 the op being freed "real soon now". Under MAD, this doesn't
3294 happen (see the #ifdef below). */
3295 sv = newSVsv(sv);
3296#else
b7f7fd0b 3297 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC
3298#endif
3299 }
b7f7fd0b
NC
3300 else if (SvTEMP(sv)) { /* grab mortal temp? */
3301 SvREFCNT_inc_simple_void(sv);
3302 SvTEMP_off(sv);
3303 }
ba610af8 3304 else { assert(SvIMMORTAL(sv)); }
b7f7fd0b
NC
3305 break;
3306 case 3:
3307 /* Something tried to die. Abandon constant folding. */
3308 /* Pretend the error never happened. */
ab69dbc2 3309 CLEAR_ERRSV();
b7f7fd0b
NC
3310 o->op_next = old_next;
3311 break;
3312 default:
3313 JMPENV_POP;
5f2d9966
DM
3314 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3315 PL_warnhook = oldwarnhook;
3316 PL_diehook = olddiehook;
3317 /* XXX note that this croak may fail as we've already blown away
3318 * the stack - eg any nested evals */
b7f7fd0b
NC
3319 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3320 }
b7f7fd0b 3321 JMPENV_POP;
5f2d9966
DM
3322 PL_warnhook = oldwarnhook;
3323 PL_diehook = olddiehook;
c427f4d2 3324 PL_curcop = &PL_compiling;
edb2152a
NC
3325
3326 if (PL_scopestack_ix > oldscope)
3327 delete_eval_scope();
eb8433b7 3328
b7f7fd0b
NC
3329 if (ret)
3330 goto nope;
3331
eb8433b7 3332#ifndef PERL_MAD
79072805 3333 op_free(o);
eb8433b7 3334#endif
de5e01c2 3335 assert(sv);
2484f8db 3336 if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
79072805 3337 if (type == OP_RV2GV)
159b6efe 3338 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3339 else
3513c740 3340 {
cc2ebcd7 3341 newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
3513c740
NT
3342 newop->op_folded = 1;
3343 }
eb8433b7
NC
3344 op_getmad(o,newop,'f');
3345 return newop;
aeea060c 3346
b7f7fd0b 3347 nope:
79072805
LW
3348 return o;
3349}
3350
1f676739 3351static OP *
5aaab254 3352S_gen_constant_list(pTHX_ OP *o)
79072805 3353{
27da23d5 3354 dVAR;
eb578fdb 3355 OP *curop;
6867be6d 3356 const I32 oldtmps_floor = PL_tmps_floor;
5608dcc6
FC
3357 SV **svp;
3358 AV *av;
79072805 3359
a0d0e21e 3360 list(o);
13765c85 3361 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW
3362 return o; /* Don't attempt to run with errors */
3363
533c011a 3364 PL_op = curop = LINKLIST(o);
a0d0e21e 3365 o->op_next = 0;
a2efc822 3366 CALL_PEEP(curop);
897d3989 3367 Perl_pp_pushmark(aTHX);
cea2e8a9 3368 CALLRUNOPS(aTHX);
533c011a 3369 PL_op = curop;
78c72037
NC
3370 assert (!(curop->op_flags & OPf_SPECIAL));
3371 assert(curop->op_type == OP_RANGE);
897d3989 3372 Perl_pp_anonlist(aTHX);
3280af22 3373 PL_tmps_floor = oldtmps_floor;
79072805
LW
3374
3375 o->op_type = OP_RV2AV;
22c35a8c 3376 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG
3377 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3378 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3379 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3380 curop = ((UNOP*)o)->op_first;
5608dcc6
FC
3381 av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3382 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3383 if (AvFILLp(av) != -1)
3384 for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3385 SvPADTMP_on(*svp);
eb8433b7
NC
3386#ifdef PERL_MAD
3387 op_getmad(curop,o,'O');
3388#else
79072805 3389 op_free(curop);
eb8433b7 3390#endif
5983a79d 3391 LINKLIST(o);
79072805
LW
3392 return list(o);
3393}
3394
3395OP *
864dbfa3 3396Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3397{
27da23d5 3398 dVAR;
d67594ff 3399 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3400 if (!o || o->op_type != OP_LIST)
5f66b61c 3401 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3402 else
5dc0d613 3403 o->op_flags &= ~OPf_WANT;
79072805 3404
22c35a8c 3405 if (!(PL_opargs[type] & OA_MARK))
93c66552 3406 op_null(cLISTOPo->op_first);
bf0571fd
FC
3407 else {
3408 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3409 if (kid2 && kid2->op_type == OP_COREARGS) {
3410 op_null(cLISTOPo->op_first);
3411 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3412 }
3413 }
8990e307 3414
eb160463 3415 o->op_type = (OPCODE)type;
22c35a8c 3416 o->op_ppaddr = PL_ppaddr[type];
11343788 3417 o->op_flags |= flags;
79072805 3418
11343788 3419 o = CHECKOP(type, o);
fe2774ed 3420 if (o->op_type != (unsigned)type)
11343788 3421 return o;
79072805 3422
985b9e54 3423 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW
3424}
3425
2fcb4757
Z
3426/*
3427=head1 Optree Manipulation Functions
3428*/
3429
79072805
LW
3430/* List constructors */
3431
2fcb4757
Z
3432/*
3433=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3434
3435Append an item to the list of ops contained directly within a list-type
3436op, returning the lengthened list. I<first> is the list-type op,
3437and I<last> is the op to append to the list. I<optype> specifies the
3438intended opcode for the list. If I<first> is not already a list of the
3439right type, it will be upgraded into one. If either I<first> or I<last>
3440is null, the other is returned unchanged.
3441
3442=cut
3443*/
3444
79072805 3445OP *
2fcb4757 3446Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3447{
3448 if (!first)
3449 return last;
8990e307
LW
3450
3451 if (!last)
79072805 3452 return first;
8990e307 3453
fe2774ed 3454 if (first->op_type != (unsigned)type
155aba94
GS
3455 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3456 {
3457 return newLISTOP(type, 0, first, last);
3458 }
79072805 3459
a0d0e21e
LW
3460 if (first->op_flags & OPf_KIDS)
3461 ((LISTOP*)first)->op_last->op_sibling = last;
3462 else {
3463 first->op_flags |= OPf_KIDS;
3464 ((LISTOP*)first)->op_first = last;
3465 }
3466 ((LISTOP*)first)->op_last = last;
a0d0e21e 3467 return first;
79072805
LW
3468}
3469
2fcb4757
Z
3470/*
3471=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3472
3473Concatenate the lists of ops contained directly within two list-type ops,
3474returning the combined list. I<first> and I<last> are the list-type ops
3475to concatenate. I<optype> specifies the intended opcode for the list.
3476If either I<first> or I<last> is not already a list of the right type,
3477it will be upgraded into one. If either I<first> or I<last> is null,
3478the other is returned unchanged.
3479
3480=cut
3481*/
3482
79072805 3483OP *
2fcb4757 3484Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3485{
3486 if (!first)
2fcb4757 3487 return last;
8990e307
LW
3488
3489 if (!last)
2fcb4757 3490 return first;
8990e307 3491
fe2774ed 3492 if (first->op_type != (unsigned)type)
2fcb4757 3493 return op_prepend_elem(type, first, last);
8990e307 3494
fe2774ed 3495 if (last->op_type != (unsigned)type)
2fcb4757 3496 return op_append_elem(type, first, last);
79072805 3497
2fcb4757
Z
3498 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3499 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3500 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3501
eb8433b7 3502#ifdef PERL_MAD
2fcb4757
Z
3503 if (((LISTOP*)last)->op_first && first->op_madprop) {
3504 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC
3505 if (mp) {
3506 while (mp->mad_next)
3507 mp = mp->mad_next;
3508 mp->mad_next = first->op_madprop;
3509 }
3510 else {
2fcb4757 3511 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC
3512 }
3513 }
3514 first->op_madprop = last->op_madprop;
3515 last->op_madprop = 0;
3516#endif
3517
2fcb4757 3518 S_op_destroy(aTHX_ last);
238a4c30 3519
2fcb4757 3520 return first;
79072805
LW
3521}
3522
2fcb4757
Z
3523/*
3524=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3525
3526Prepend an item to the list of ops contained directly within a list-type
3527op, returning the lengthened list. I<first> is the op to prepend to the
3528list, and I<last> is the list-type op. I<optype> specifies the intended
3529opcode for the list. If I<last> is not already a list of the right type,
3530it will be upgraded into one. If either I<first> or I<last> is null,
3531the other is returned unchanged.
3532
3533=cut
3534*/
3535
79072805 3536OP *
2fcb4757 3537Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW
3538{
3539 if (!first)
3540 return last;
8990e307
LW
3541
3542 if (!last)
79072805 3543 return first;
8990e307 3544
fe2774ed 3545 if (last->op_type == (unsigned)type) {
8990e307
LW
3546 if (type == OP_LIST) { /* already a PUSHMARK there */
3547 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3548 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC
3549 if (!(first->op_flags & OPf_PARENS))
3550 last->op_flags &= ~OPf_PARENS;
8990e307
LW
3551 }
3552 else {
3553 if (!(last->op_flags & OPf_KIDS)) {
3554 ((LISTOP*)last)->op_last = first;
3555 last->op_flags |= OPf_KIDS;
3556 }
3557 first->op_sibling = ((LISTOP*)last)->op_first;
3558 ((LISTOP*)last)->op_first = first;
79072805 3559 }
117dada2 3560 last->op_flags |= OPf_KIDS;
79072805
LW
3561 return last;
3562 }
3563
3564 return newLISTOP(type, 0, first, last);
3565}
3566
3567/* Constructors */
3568
eb8433b7
NC
3569#ifdef PERL_MAD
3570
3571TOKEN *
3572Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3573{
3574 TOKEN *tk;
99129197 3575 Newxz(tk, 1, TOKEN);
eb8433b7
NC
3576 tk->tk_type = (OPCODE)optype;
3577 tk->tk_type = 12345;
3578 tk->tk_lval = lval;
3579 tk->tk_mad = madprop;
3580 return tk;
3581}
3582
3583void
3584Perl_token_free(pTHX_ TOKEN* tk)
3585{
7918f24d
NC
3586 PERL_ARGS_ASSERT_TOKEN_FREE;
3587
eb8433b7
NC
3588 if (tk->tk_type != 12345)
3589 return;
3590 mad_free(tk->tk_mad);
3591 Safefree(tk);
3592}
3593
3594void
3595Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3596{
3597 MADPROP* mp;
3598 MADPROP* tm;
7918f24d
NC
3599
3600 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3601
eb8433b7
NC
3602 if (tk->tk_type != 12345) {
3603 Perl_warner(aTHX_ packWARN(WARN_MISC),
3604 "Invalid TOKEN object ignored");
3605 return;
3606 }
3607 tm = tk->tk_mad;
3608 if (!tm)
3609 return;
3610
3611 /* faked up qw list? */
3612 if (slot == '(' &&
3613 tm->mad_type == MAD_SV &&
d503a9ba 3614 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC
3615 slot = 'x';
3616
3617 if (o) {
3618 mp = o->op_madprop;
3619 if (mp) {
3620 for (;;) {
3621 /* pretend constant fold didn't happen? */
3622 if (mp->mad_key == 'f' &&
3623 (o->op_type == OP_CONST ||
3624 o->op_type == OP_GV) )
3625 {
3626 token_getmad(tk,(OP*)mp->mad_val,slot);
3627 return;
3628 }
3629 if (!mp->mad_next)
3630 break;
3631 mp = mp->mad_next;
3632 }
3633 mp->mad_next = tm;
3634 mp = mp->mad_next;
3635 }
3636 else {
3637 o->op_madprop = tm;