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