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