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