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