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