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