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