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