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