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