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