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