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