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