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