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