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