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