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