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
Add comments describing the operation of S_scan_ident().
[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 }
4055dbce
RS		 581 else if (len == 2 && name[1] == '_' && !is_our)
582 /* diag_listed_as: Use of my $_ is experimental */
583 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
584 "Use of %s $_ is experimental",
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 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 802 int try_downgrade = SvREFCNT(gv) == 2;
fc2b2dca 803 SvREFCNT_dec_NN(gv);
f7461760
Z		 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 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));
fc2b2dca 1390 SvREFCNT_dec_NN(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);
fc2b2dca 1806 SvREFCNT_dec_NN(sv);
d164302a
GG		 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 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:
ddeae0f1 2074 localize = 1;
78f9721b
SM		 2075 /* FALL THROUGH */
2076 case OP_AASSIGN:
631dbaa2
FC		 2077 if (type == OP_LEAVESUBLV)
2078 o->op_private |= OPpMAYBE_LVSUB;
2079 /* FALL THROUGH */
93a17b20
LW		 2080 case OP_NEXTSTATE:
2081 case OP_DBSTATE:
e6438c1a 2082 PL_modcount = RETURN_UNLIMITED_NUMBER;
79072805 2083 break;
28c5b5bc
RGS		 2084 case OP_AV2ARYLEN:
2085 PL_hints |= HINT_BLOCK_SCOPE;
2086 if (type == OP_LEAVESUBLV)
2087 o->op_private |= OPpMAYBE_LVSUB;
2088 PL_modcount++;
2089 break;
463ee0b2 2090 case OP_RV2SV:
aeea060c 2091 ref(cUNOPo->op_first, o->op_type);
ddeae0f1 2092 localize = 1;
463ee0b2 2093 /* FALL THROUGH */
79072805 2094 case OP_GV:
3280af22 2095 PL_hints |= HINT_BLOCK_SCOPE;
463ee0b2 2096 case OP_SASSIGN:
bf4b1e52
GS		 2097 case OP_ANDASSIGN:
2098 case OP_ORASSIGN:
c963b151 2099 case OP_DORASSIGN:
ddeae0f1
DM		 2100 PL_modcount++;
2101 break;
2102
8990e307 2103 case OP_AELEMFAST:
93bad3fd 2104 case OP_AELEMFAST_LEX:
6a077020 2105 localize = -1;
3280af22 2106 PL_modcount++;
8990e307
LW		 2107 break;
2108
748a9306
LW		 2109 case OP_PADAV:
2110 case OP_PADHV:
e6438c1a 2111 PL_modcount = RETURN_UNLIMITED_NUMBER;
5196be3e
MB		 2112 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2113 return o; /* Treat \(@foo) like ordinary list. */
2114 if (scalar_mod_type(o, type))
3fe9a6f1 2115 goto nomod;
78f9721b
SM		 2116 if (type == OP_LEAVESUBLV)
2117 o->op_private |= OPpMAYBE_LVSUB;
748a9306
LW		 2118 /* FALL THROUGH */
2119 case OP_PADSV:
3280af22 2120 PL_modcount++;
ddeae0f1 2121 if (!type) /* local() */
5ede95a0
BF		 2122 Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2123 PAD_COMPNAME_SV(o->op_targ));
463ee0b2
LW		 2124 break;
2125
748a9306 2126 case OP_PUSHMARK:
ddeae0f1 2127 localize = 0;
748a9306 2128 break;
b2ffa427 2129
69969c6f 2130 case OP_KEYS:
d8065907 2131 case OP_RKEYS:
fad4a2e4 2132 if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
69969c6f 2133 goto nomod;
5d82c453
GA		 2134 goto lvalue_func;
2135 case OP_SUBSTR:
2136 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2137 goto nomod;
5f05dabc 2138 /* FALL THROUGH */
a0d0e21e 2139 case OP_POS:
463ee0b2 2140 case OP_VEC:
fad4a2e4 2141 lvalue_func:
78f9721b
SM		 2142 if (type == OP_LEAVESUBLV)
2143 o->op_private |= OPpMAYBE_LVSUB;
11343788
MB		 2144 pad_free(o->op_targ);
2145 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
5dc0d613 2146 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
11343788 2147 if (o->op_flags & OPf_KIDS)
3ad73efd 2148 op_lvalue(cBINOPo->op_first->op_sibling, type);
463ee0b2 2149 break;
a0d0e21e 2150
463ee0b2
LW		 2151 case OP_AELEM:
2152 case OP_HELEM:
11343788 2153 ref(cBINOPo->op_first, o->op_type);
68dc0745 2154 if (type == OP_ENTERSUB &&
5dc0d613
MB		 2155 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2156 o->op_private |= OPpLVAL_DEFER;
78f9721b
SM		 2157 if (type == OP_LEAVESUBLV)
2158 o->op_private |= OPpMAYBE_LVSUB;
ddeae0f1 2159 localize = 1;
3280af22 2160 PL_modcount++;
463ee0b2
LW		 2161 break;
2162
2163 case OP_SCOPE:
2164 case OP_LEAVE:
2165 case OP_ENTER:
78f9721b 2166 case OP_LINESEQ:
ddeae0f1 2167 localize = 0;
11343788 2168 if (o->op_flags & OPf_KIDS)
3ad73efd 2169 op_lvalue(cLISTOPo->op_last, type);
a0d0e21e
LW		 2170 break;
2171
2172 case OP_NULL:
ddeae0f1 2173 localize = 0;
638bc118
GS		 2174 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
2175 goto nomod;
2176 else if (!(o->op_flags & OPf_KIDS))
463ee0b2 2177 break;
11343788 2178 if (o->op_targ != OP_LIST) {
3ad73efd 2179 op_lvalue(cBINOPo->op_first, type);
a0d0e21e
LW		 2180 break;
2181 }
2182 /* FALL THROUGH */
463ee0b2 2183 case OP_LIST:
ddeae0f1 2184 localize = 0;
11343788 2185 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
5c906035
GG		 2186 /* elements might be in void context because the list is
2187 in scalar context or because they are attribute sub calls */
2188 if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2189 op_lvalue(kid, type);
463ee0b2 2190 break;
78f9721b
SM		 2191
2192 case OP_RETURN:
2193 if (type != OP_LEAVESUBLV)
2194 goto nomod;
3ad73efd 2195 break; /* op_lvalue()ing was handled by ck_return() */
1efec5ed
FC		 2196
2197 case OP_COREARGS:
2198 return o;
463ee0b2 2199 }
58d95175 2200
8be1be90
AMS		 2201 /* [20011101.069] File test operators interpret OPf_REF to mean that
2202 their argument is a filehandle; thus \stat(".") should not set
2203 it. AMS 20011102 */
2204 if (type == OP_REFGEN &&
ef69c8fc 2205 PL_check[o->op_type] == Perl_ck_ftst)
8be1be90
AMS		 2206 return o;
2207
2208 if (type != OP_LEAVESUBLV)
2209 o->op_flags |= OPf_MOD;
2210
2211 if (type == OP_AASSIGN || type == OP_SASSIGN)
2212 o->op_flags |= OPf_SPECIAL|OPf_REF;
ddeae0f1
DM		 2213 else if (!type) { /* local() */
2214 switch (localize) {
2215 case 1:
2216 o->op_private |= OPpLVAL_INTRO;
2217 o->op_flags &= ~OPf_SPECIAL;
2218 PL_hints |= HINT_BLOCK_SCOPE;
2219 break;
2220 case 0:
2221 break;
2222 case -1:
a2a5de95
NC		 2223 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2224 "Useless localization of %s", OP_DESC(o));
ddeae0f1 2225 }
463ee0b2 2226 }
8be1be90
AMS		 2227 else if (type != OP_GREPSTART && type != OP_ENTERSUB
2228 && type != OP_LEAVESUBLV)
2229 o->op_flags |= OPf_REF;
11343788 2230 return o;
463ee0b2
LW		 2231}
2232
864dbfa3 2233STATIC bool
5f66b61c 2234S_scalar_mod_type(const OP *o, I32 type)
3fe9a6f1 2235{
2236 switch (type) {
32a60974 2237 case OP_POS:
3fe9a6f1 2238 case OP_SASSIGN:
1efec5ed 2239 if (o && o->op_type == OP_RV2GV)
3fe9a6f1 2240 return FALSE;
2241 /* FALL THROUGH */
2242 case OP_PREINC:
2243 case OP_PREDEC:
2244 case OP_POSTINC:
2245 case OP_POSTDEC:
2246 case OP_I_PREINC:
2247 case OP_I_PREDEC:
2248 case OP_I_POSTINC:
2249 case OP_I_POSTDEC:
2250 case OP_POW:
2251 case OP_MULTIPLY:
2252 case OP_DIVIDE:
2253 case OP_MODULO:
2254 case OP_REPEAT:
2255 case OP_ADD:
2256 case OP_SUBTRACT:
2257 case OP_I_MULTIPLY:
2258 case OP_I_DIVIDE:
2259 case OP_I_MODULO:
2260 case OP_I_ADD:
2261 case OP_I_SUBTRACT:
2262 case OP_LEFT_SHIFT:
2263 case OP_RIGHT_SHIFT:
2264 case OP_BIT_AND:
2265 case OP_BIT_XOR:
2266 case OP_BIT_OR:
2267 case OP_CONCAT:
2268 case OP_SUBST:
2269 case OP_TRANS:
bb16bae8 2270 case OP_TRANSR:
49e9fbe6
GS		 2271 case OP_READ:
2272 case OP_SYSREAD:
2273 case OP_RECV:
bf4b1e52
GS		 2274 case OP_ANDASSIGN:
2275 case OP_ORASSIGN:
410d09fe 2276 case OP_DORASSIGN:
3fe9a6f1 2277 return TRUE;
2278 default:
2279 return FALSE;
2280 }
2281}
2282
35cd451c 2283STATIC bool
5f66b61c 2284S_is_handle_constructor(const OP *o, I32 numargs)
35cd451c 2285{
7918f24d
NC		 2286 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2287
35cd451c
GS		 2288 switch (o->op_type) {
2289 case OP_PIPE_OP:
2290 case OP_SOCKPAIR:
504618e9 2291 if (numargs == 2)
35cd451c
GS		 2292 return TRUE;
2293 /* FALL THROUGH */
2294 case OP_SYSOPEN:
2295 case OP_OPEN:
ded8aa31 2296 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
35cd451c
GS		 2297 case OP_SOCKET:
2298 case OP_OPEN_DIR:
2299 case OP_ACCEPT:
504618e9 2300 if (numargs == 1)
35cd451c 2301 return TRUE;
5f66b61c 2302 /* FALLTHROUGH */
35cd451c
GS		 2303 default:
2304 return FALSE;
2305 }
2306}
2307
0d86688d
NC		 2308static OP *
2309S_refkids(pTHX_ OP *o, I32 type)
463ee0b2 2310{
11343788 2311 if (o && o->op_flags & OPf_KIDS) {
6867be6d 2312 OP *kid;
11343788 2313 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
463ee0b2
LW		 2314 ref(kid, type);
2315 }
11343788 2316 return o;
463ee0b2
LW		 2317}
2318
2319OP *
e4c5ccf3 2320Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
463ee0b2 2321{
27da23d5 2322 dVAR;
463ee0b2 2323 OP *kid;
463ee0b2 2324
7918f24d
NC		 2325 PERL_ARGS_ASSERT_DOREF;
2326
13765c85 2327 if (!o || (PL_parser && PL_parser->error_count))
11343788 2328 return o;
463ee0b2 2329
11343788 2330 switch (o->op_type) {
a0d0e21e 2331 case OP_ENTERSUB:
f4df43b5 2332 if ((type == OP_EXISTS || type == OP_DEFINED) &&
11343788
MB		 2333 !(o->op_flags & OPf_STACKED)) {
2334 o->op_type = OP_RV2CV; /* entersub => rv2cv */
22c35a8c 2335 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
11343788 2336 assert(cUNOPo->op_first->op_type == OP_NULL);
93c66552 2337 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
11343788 2338 o->op_flags |= OPf_SPECIAL;
e26df76a 2339 o->op_private &= ~1;
8990e307 2340 }
767eda44 2341 else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
0e9700df
GG		 2342 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2343 : type == OP_RV2HV ? OPpDEREF_HV
2344 : OPpDEREF_SV);
767eda44
FC		 2345 o->op_flags |= OPf_MOD;
2346 }
2347
8990e307 2348 break;
aeea060c 2349
463ee0b2 2350 case OP_COND_EXPR:
11343788 2351 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
e4c5ccf3 2352 doref(kid, type, set_op_ref);
463ee0b2 2353 break;
8990e307 2354 case OP_RV2SV:
35cd451c
GS		 2355 if (type == OP_DEFINED)
2356 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2357 doref(cUNOPo->op_first, o->op_type, set_op_ref);
4633a7c4
LW		 2358 /* FALL THROUGH */
2359 case OP_PADSV:
5f05dabc 2360 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2361 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2362 : type == OP_RV2HV ? OPpDEREF_HV
2363 : OPpDEREF_SV);
11343788 2364 o->op_flags |= OPf_MOD;
a0d0e21e 2365 }
8990e307 2366 break;
1c846c1f 2367
463ee0b2
LW		 2368 case OP_RV2AV:
2369 case OP_RV2HV:
e4c5ccf3
RH		 2370 if (set_op_ref)
2371 o->op_flags |= OPf_REF;
8990e307 2372 /* FALL THROUGH */
463ee0b2 2373 case OP_RV2GV:
35cd451c
GS		 2374 if (type == OP_DEFINED)
2375 o->op_flags |= OPf_SPECIAL; /* don't create GV */
e4c5ccf3 2376 doref(cUNOPo->op_first, o->op_type, set_op_ref);
463ee0b2 2377 break;
8990e307 2378
463ee0b2
LW		 2379 case OP_PADAV:
2380 case OP_PADHV:
e4c5ccf3
RH		 2381 if (set_op_ref)
2382 o->op_flags |= OPf_REF;
79072805 2383 break;
aeea060c 2384
8990e307 2385 case OP_SCALAR:
79072805 2386 case OP_NULL:
518618af 2387 if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
463ee0b2 2388 break;
e4c5ccf3 2389 doref(cBINOPo->op_first, type, set_op_ref);
79072805
LW		 2390 break;
2391 case OP_AELEM:
2392 case OP_HELEM:
e4c5ccf3 2393 doref(cBINOPo->op_first, o->op_type, set_op_ref);
5f05dabc 2394 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
5dc0d613
MB		 2395 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2396 : type == OP_RV2HV ? OPpDEREF_HV
2397 : OPpDEREF_SV);
11343788 2398 o->op_flags |= OPf_MOD;
8990e307 2399 }
79072805
LW		 2400 break;
2401
463ee0b2 2402 case OP_SCOPE:
79072805 2403 case OP_LEAVE:
e4c5ccf3
RH		 2404 set_op_ref = FALSE;
2405 /* FALL THROUGH */
79072805 2406 case OP_ENTER:
8990e307 2407 case OP_LIST:
11343788 2408 if (!(o->op_flags & OPf_KIDS))
79072805 2409 break;
e4c5ccf3 2410 doref(cLISTOPo->op_last, type, set_op_ref);
79072805 2411 break;
a0d0e21e
LW		 2412 default:
2413 break;
79072805 2414 }
11343788 2415 return scalar(o);
8990e307 2416
79072805
LW		 2417}
2418
09bef843
SB		 2419STATIC OP *
2420S_dup_attrlist(pTHX_ OP *o)
2421{
97aff369 2422 dVAR;
0bd48802 2423 OP *rop;
09bef843 2424
7918f24d
NC		 2425 PERL_ARGS_ASSERT_DUP_ATTRLIST;
2426
09bef843
SB		 2427 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2428 * where the first kid is OP_PUSHMARK and the remaining ones
2429 * are OP_CONST. We need to push the OP_CONST values.
2430 */
2431 if (o->op_type == OP_CONST)
b37c2d43 2432 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
eb8433b7
NC		 2433#ifdef PERL_MAD
2434 else if (o->op_type == OP_NULL)
1d866c12 2435 rop = NULL;
eb8433b7 2436#endif
09bef843
SB		 2437 else {
2438 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
5f66b61c 2439 rop = NULL;
09bef843
SB		 2440 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2441 if (o->op_type == OP_CONST)
2fcb4757 2442 rop = op_append_elem(OP_LIST, rop,
09bef843 2443 newSVOP(OP_CONST, o->op_flags,
b37c2d43 2444 SvREFCNT_inc_NN(cSVOPo->op_sv)));
09bef843
SB		 2445 }
2446 }
2447 return rop;
2448}
2449
2450STATIC void
ad0dc73b 2451S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
09bef843 2452{
27da23d5 2453 dVAR;
ad0dc73b 2454 SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
09bef843 2455
7918f24d
NC		 2456 PERL_ARGS_ASSERT_APPLY_ATTRS;
2457
09bef843
SB		 2458 /* fake up C<use attributes $pkg,$rv,@attrs> */
2459 ENTER; /* need to protect against side-effects of 'use' */
e4783991 2460
09bef843 2461#define ATTRSMODULE "attributes"
95f0a2f1
SB		 2462#define ATTRSMODULE_PM "attributes.pm"
2463
ad0dc73b 2464 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704
AL		 2465 newSVpvs(ATTRSMODULE),
2466 NULL,
2fcb4757 2467 op_prepend_elem(OP_LIST,
95f0a2f1 2468 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2469 op_prepend_elem(OP_LIST,
95f0a2f1
SB		 2470 newSVOP(OP_CONST, 0,
2471 newRV(target)),
2472 dup_attrlist(attrs))));
09bef843
SB		 2473 LEAVE;
2474}
2475
95f0a2f1
SB		 2476STATIC void
2477S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2478{
97aff369 2479 dVAR;
95f0a2f1 2480 OP *pack, *imop, *arg;
ad0dc73b 2481 SV *meth, *stashsv, **svp;
95f0a2f1 2482
7918f24d
NC		 2483 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2484
95f0a2f1
SB		 2485 if (!attrs)
2486 return;
2487
2488 assert(target->op_type == OP_PADSV ||
2489 target->op_type == OP_PADHV ||
2490 target->op_type == OP_PADAV);
2491
2492 /* Ensure that attributes.pm is loaded. */
ad0dc73b
FC		 2493 ENTER; /* need to protect against side-effects of 'use' */
2494 /* Don't force the C<use> if we don't need it. */
2495 svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2496 if (svp && *svp != &PL_sv_undef)
2497 NOOP; /* already in %INC */
2498 else
2499 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2500 newSVpvs(ATTRSMODULE), NULL);
2501 LEAVE;
95f0a2f1
SB		 2502
2503 /* Need package name for method call. */
6136c704 2504 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
95f0a2f1
SB		 2505
2506 /* Build up the real arg-list. */
5aaec2b4
NC		 2507 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2508
95f0a2f1
SB		 2509 arg = newOP(OP_PADSV, 0);
2510 arg->op_targ = target->op_targ;
2fcb4757 2511 arg = op_prepend_elem(OP_LIST,
95f0a2f1 2512 newSVOP(OP_CONST, 0, stashsv),
2fcb4757 2513 op_prepend_elem(OP_LIST,
95f0a2f1 2514 newUNOP(OP_REFGEN, 0,
3ad73efd 2515 op_lvalue(arg, OP_REFGEN)),
95f0a2f1
SB		 2516 dup_attrlist(attrs)));
2517
2518 /* Fake up a method call to import */
18916d0d 2519 meth = newSVpvs_share("import");
95f0a2f1 2520 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2fcb4757
Z		 2521 op_append_elem(OP_LIST,
2522 op_prepend_elem(OP_LIST, pack, list(arg)),
95f0a2f1 2523 newSVOP(OP_METHOD_NAMED, 0, meth)));
95f0a2f1
SB		 2524
2525 /* Combine the ops. */
2fcb4757 2526 *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
95f0a2f1
SB		 2527}
2528
2529/*
2530=notfor apidoc apply_attrs_string
2531
2532Attempts to apply a list of attributes specified by the C<attrstr> and
2533C<len> arguments to the subroutine identified by the C<cv> argument which
2534is expected to be associated with the package identified by the C<stashpv>
2535argument (see L<attributes>). It gets this wrong, though, in that it
2536does not correctly identify the boundaries of the individual attribute
2537specifications within C<attrstr>. This is not really intended for the
2538public API, but has to be listed here for systems such as AIX which
2539need an explicit export list for symbols. (It's called from XS code
2540in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2541to respect attribute syntax properly would be welcome.
2542
2543=cut
2544*/
2545
be3174d2 2546void
6867be6d
AL		 2547Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2548 const char *attrstr, STRLEN len)
be3174d2 2549{
5f66b61c 2550 OP *attrs = NULL;
be3174d2 2551
7918f24d
NC		 2552 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2553
be3174d2
GS		 2554 if (!len) {
2555 len = strlen(attrstr);
2556 }
2557
2558 while (len) {
2559 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2560 if (len) {
890ce7af 2561 const char * const sstr = attrstr;
be3174d2 2562 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2fcb4757 2563 attrs = op_append_elem(OP_LIST, attrs,
be3174d2
GS		 2564 newSVOP(OP_CONST, 0,
2565 newSVpvn(sstr, attrstr-sstr)));
2566 }
2567 }
2568
2569 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
6136c704 2570 newSVpvs(ATTRSMODULE),
2fcb4757 2571 NULL, op_prepend_elem(OP_LIST,
be3174d2 2572 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2fcb4757 2573 op_prepend_elem(OP_LIST,
be3174d2 2574 newSVOP(OP_CONST, 0,
ad64d0ec 2575 newRV(MUTABLE_SV(cv))),
be3174d2
GS		 2576 attrs)));
2577}
2578
09bef843 2579STATIC OP *
95f0a2f1 2580S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
93a17b20 2581{
97aff369 2582 dVAR;
93a17b20 2583 I32 type;
a1fba7eb 2584 const bool stately = PL_parser && PL_parser->in_my == KEY_state;
93a17b20 2585
7918f24d
NC		 2586 PERL_ARGS_ASSERT_MY_KID;
2587
13765c85 2588 if (!o || (PL_parser && PL_parser->error_count))
11343788 2589 return o;
93a17b20 2590
bc61e325 2591 type = o->op_type;
eb8433b7
NC		 2592 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2593 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2594 return o;
2595 }
2596
93a17b20 2597 if (type == OP_LIST) {
6867be6d 2598 OP *kid;
11343788 2599 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
95f0a2f1 2600 my_kid(kid, attrs, imopsp);
0865059d 2601 return o;
8b8c1fb9 2602 } else if (type == OP_UNDEF || type == OP_STUB) {
7766148a 2603 return o;
77ca0c92
LW		 2604 } else if (type == OP_RV2SV || /* "our" declaration */
2605 type == OP_RV2AV ||
2606 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1ce0b88c 2607 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
fab01b8e 2608 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
952306ac 2609 OP_DESC(o),
12bd6ede
DM		 2610 PL_parser->in_my == KEY_our
2611 ? "our"
2612 : PL_parser->in_my == KEY_state ? "state" : "my"));
1ce0b88c 2613 } else if (attrs) {
551405c4 2614 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
12bd6ede
DM		 2615 PL_parser->in_my = FALSE;
2616 PL_parser->in_my_stash = NULL;
1ce0b88c
RGS		 2617 apply_attrs(GvSTASH(gv),
2618 (type == OP_RV2SV ? GvSV(gv) :
ad64d0ec
NC		 2619 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2620 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
ad0dc73b 2621 attrs);
1ce0b88c 2622 }
192587c2 2623 o->op_private |= OPpOUR_INTRO;
77ca0c92 2624 return o;
95f0a2f1
SB		 2625 }
2626 else if (type != OP_PADSV &&
93a17b20
LW		 2627 type != OP_PADAV &&
2628 type != OP_PADHV &&
2629 type != OP_PUSHMARK)
2630 {
eb64745e 2631 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
53e06cf0 2632 OP_DESC(o),
12bd6ede
DM		 2633 PL_parser->in_my == KEY_our
2634 ? "our"
2635 : PL_parser->in_my == KEY_state ? "state" : "my"));
11343788 2636 return o;
93a17b20 2637 }
09bef843
SB		 2638 else if (attrs && type != OP_PUSHMARK) {
2639 HV *stash;
09bef843 2640
12bd6ede
DM		 2641 PL_parser->in_my = FALSE;
2642 PL_parser->in_my_stash = NULL;
eb64745e 2643
09bef843 2644 /* check for C<my Dog $spot> when deciding package */
dd2155a4
DM		 2645 stash = PAD_COMPNAME_TYPE(o->op_targ);
2646 if (!stash)
09bef843 2647 stash = PL_curstash;
95f0a2f1 2648 apply_attrs_my(stash, o, attrs, imopsp);
09bef843 2649 }
11343788
MB		 2650 o->op_flags |= OPf_MOD;
2651 o->op_private |= OPpLVAL_INTRO;
a1fba7eb 2652 if (stately)
952306ac 2653 o->op_private |= OPpPAD_STATE;
11343788 2654 return o;
93a17b20
LW		 2655}
2656
2657OP *
09bef843
SB		 2658Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2659{
97aff369 2660 dVAR;
0bd48802 2661 OP *rops;
95f0a2f1
SB		 2662 int maybe_scalar = 0;
2663
7918f24d
NC		 2664 PERL_ARGS_ASSERT_MY_ATTRS;
2665
d2be0de5 2666/* [perl #17376]: this appears to be premature, and results in code such as
c754c3d7 2667 C< our(%x); > executing in list mode rather than void mode */
d2be0de5 2668#if 0
09bef843
SB		 2669 if (o->op_flags & OPf_PARENS)
2670 list(o);
95f0a2f1
SB		 2671 else
2672 maybe_scalar = 1;
d2be0de5
YST		 2673#else
2674 maybe_scalar = 1;
2675#endif
09bef843
SB		 2676 if (attrs)
2677 SAVEFREEOP(attrs);
5f66b61c 2678 rops = NULL;
95f0a2f1
SB		 2679 o = my_kid(o, attrs, &rops);
2680 if (rops) {
2681 if (maybe_scalar && o->op_type == OP_PADSV) {
2fcb4757 2682 o = scalar(op_append_list(OP_LIST, rops, o));
95f0a2f1
SB		 2683 o->op_private |= OPpLVAL_INTRO;
2684 }
f5d1ed10
FC		 2685 else {
2686 /* The listop in rops might have a pushmark at the beginning,
2687 which will mess up list assignment. */
2688 LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2689 if (rops->op_type == OP_LIST &&
2690 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2691 {
2692 OP * const pushmark = lrops->op_first;
2693 lrops->op_first = pushmark->op_sibling;
2694 op_free(pushmark);
2695 }
2fcb4757 2696 o = op_append_list(OP_LIST, o, rops);
f5d1ed10 2697 }
95f0a2f1 2698 }
12bd6ede
DM		 2699 PL_parser->in_my = FALSE;
2700 PL_parser->in_my_stash = NULL;
eb64745e 2701 return o;
09bef843
SB		 2702}
2703
2704OP *
864dbfa3 2705Perl_sawparens(pTHX_ OP *o)
79072805 2706{
96a5add6 2707 PERL_UNUSED_CONTEXT;
79072805
LW		 2708 if (o)
2709 o->op_flags |= OPf_PARENS;
2710 return o;
2711}
2712
2713OP *
864dbfa3 2714Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
79072805 2715{
11343788 2716 OP *o;
59f00321 2717 bool ismatchop = 0;
1496a290
AL		 2718 const OPCODE ltype = left->op_type;
2719 const OPCODE rtype = right->op_type;
79072805 2720
7918f24d
NC		 2721 PERL_ARGS_ASSERT_BIND_MATCH;
2722
1496a290
AL		 2723 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2724 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
041457d9 2725 {
1496a290 2726 const char * const desc
bb16bae8
FC		 2727 = PL_op_desc[(
2728 rtype == OP_SUBST || rtype == OP_TRANS
2729 || rtype == OP_TRANSR
2730 )
666ea192 2731 ? (int)rtype : OP_MATCH];
c6771ab6
FC		 2732 const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
2733 GV *gv;
2734 SV * const name =
2735 (ltype == OP_RV2AV || ltype == OP_RV2HV)
2736 ? cUNOPx(left)->op_first->op_type == OP_GV
2737 && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
2738 ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
2739 : NULL
ba510004
FC		 2740 : varname(
2741 (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
2742 );
c6771ab6
FC		 2743 if (name)
2744 Perl_warner(aTHX_ packWARN(WARN_MISC),
2745 "Applying %s to %"SVf" will act on scalar(%"SVf")",
2746 desc, name, name);
2747 else {
2748 const char * const sample = (isary
666ea192 2749 ? "@array" : "%hash");
c6771ab6 2750 Perl_warner(aTHX_ packWARN(WARN_MISC),
1c846c1f 2751 "Applying %s to %s will act on scalar(%s)",
599cee73 2752 desc, sample, sample);
c6771ab6 2753 }
2ae324a7 2754 }
2755
1496a290 2756 if (rtype == OP_CONST &&
5cc9e5c9
RH		 2757 cSVOPx(right)->op_private & OPpCONST_BARE &&
2758 cSVOPx(right)->op_private & OPpCONST_STRICT)
2759 {
2760 no_bareword_allowed(right);
2761 }
2762
bb16bae8 2763 /* !~ doesn't make sense with /r, so error on it for now */
4f4d7508
DC		 2764 if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
2765 type == OP_NOT)
2766 yyerror("Using !~ with s///r doesn't make sense");
bb16bae8
FC		 2767 if (rtype == OP_TRANSR && type == OP_NOT)
2768 yyerror("Using !~ with tr///r doesn't make sense");
4f4d7508 2769
2474a784
FC		 2770 ismatchop = (rtype == OP_MATCH ||
2771 rtype == OP_SUBST ||
bb16bae8 2772 rtype == OP_TRANS || rtype == OP_TRANSR)
2474a784 2773 && !(right->op_flags & OPf_SPECIAL);
59f00321
RGS		 2774 if (ismatchop && right->op_private & OPpTARGET_MY) {
2775 right->op_targ = 0;
2776 right->op_private &= ~OPpTARGET_MY;
2777 }
2778 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1496a290
AL		 2779 OP *newleft;
2780
79072805 2781 right->op_flags |= OPf_STACKED;
bb16bae8 2782 if (rtype != OP_MATCH && rtype != OP_TRANSR &&
1496a290 2783 ! (rtype == OP_TRANS &&
4f4d7508
DC		 2784 right->op_private & OPpTRANS_IDENTICAL) &&
2785 ! (rtype == OP_SUBST &&
2786 (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3ad73efd 2787 newleft = op_lvalue(left, rtype);
1496a290
AL		 2788 else
2789 newleft = left;
bb16bae8 2790 if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
1496a290 2791 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
79072805 2792 else
2fcb4757 2793 o = op_prepend_elem(rtype, scalar(newleft), right);
79072805 2794 if (type == OP_NOT)
11343788
MB		 2795 return newUNOP(OP_NOT, 0, scalar(o));
2796 return o;
79072805
LW		 2797 }
2798 else
2799 return bind_match(type, left,
d63c20f2 2800 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
79072805
LW		 2801}
2802
2803OP *
864dbfa3 2804Perl_invert(pTHX_ OP *o)
79072805 2805{
11343788 2806 if (!o)
1d866c12 2807 return NULL;
11343788 2808 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
79072805
LW		 2809}
2810
3ad73efd
Z		 2811/*
2812=for apidoc Amx|OP *|op_scope|OP *o
2813
2814Wraps up an op tree with some additional ops so that at runtime a dynamic
2815scope will be created. The original ops run in the new dynamic scope,
2816and then, provided that they exit normally, the scope will be unwound.
2817The additional ops used to create and unwind the dynamic scope will
2818normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
2819instead if the ops are simple enough to not need the full dynamic scope
2820structure.
2821
2822=cut
2823*/
2824
79072805 2825OP *
3ad73efd 2826Perl_op_scope(pTHX_ OP *o)
79072805 2827{
27da23d5 2828 dVAR;
79072805 2829 if (o) {
284167a5 2830 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
2fcb4757 2831 o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
463ee0b2 2832 o->op_type = OP_LEAVE;
22c35a8c 2833 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
463ee0b2 2834 }
fdb22418
HS		 2835 else if (o->op_type == OP_LINESEQ) {
2836 OP *kid;
2837 o->op_type = OP_SCOPE;
2838 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2839 kid = ((LISTOP*)o)->op_first;
59110972 2840 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
fdb22418 2841 op_null(kid);
59110972
RH		 2842
2843 /* The following deals with things like 'do {1 for 1}' */
2844 kid = kid->op_sibling;
2845 if (kid &&
2846 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2847 op_null(kid);
2848 }
463ee0b2 2849 }
fdb22418 2850 else
5f66b61c 2851 o = newLISTOP(OP_SCOPE, 0, o, NULL);
79072805
LW		 2852 }
2853 return o;
2854}
1930840b 2855
705fe0e5
FC		 2856OP *
2857Perl_op_unscope(pTHX_ OP *o)
2858{
2859 if (o && o->op_type == OP_LINESEQ) {
2860 OP *kid = cLISTOPo->op_first;
2861 for(; kid; kid = kid->op_sibling)
2862 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2863 op_null(kid);
2864 }
2865 return o;
2866}
2867
a0d0e21e 2868int
864dbfa3 2869Perl_block_start(pTHX_ int full)
79072805 2870{
97aff369 2871 dVAR;
73d840c0 2872 const int retval = PL_savestack_ix;
1930840b 2873
dd2155a4 2874 pad_block_start(full);
b3ac6de7 2875 SAVEHINTS();
3280af22 2876 PL_hints &= ~HINT_BLOCK_SCOPE;
68da3b2f 2877 SAVECOMPILEWARNINGS();
72dc9ed5 2878 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1930840b 2879
a88d97bf 2880 CALL_BLOCK_HOOKS(bhk_start, full);
1930840b 2881
a0d0e21e
LW		 2882 return retval;
2883}
2884
2885OP*
864dbfa3 2886Perl_block_end(pTHX_ I32 floor, OP *seq)
a0d0e21e 2887{
97aff369 2888 dVAR;
6867be6d 2889 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1930840b 2890 OP* retval = scalarseq(seq);
6d5c2147 2891 OP *o;
1930840b 2892
a88d97bf 2893 CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
1930840b 2894
e9818f4e 2895 LEAVE_SCOPE(floor);
623e6609 2896 CopHINTS_set(&PL_compiling, PL_hints);
a0d0e21e 2897 if (needblockscope)
3280af22 2898 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
6d5c2147
FC		 2899 o = pad_leavemy();
2900
2901 if (o) {
2902 /* pad_leavemy has created a sequence of introcv ops for all my
2903 subs declared in the block. We have to replicate that list with
2904 clonecv ops, to deal with this situation:
2905
2906 sub {
2907 my sub s1;
2908 my sub s2;
2909 sub s1 { state sub foo { \&s2 } }
2910 }->()
2911
2912 Originally, I was going to have introcv clone the CV and turn
2913 off the stale flag. Since &s1 is declared before &s2, the
2914 introcv op for &s1 is executed (on sub entry) before the one for
2915 &s2. But the &foo sub inside &s1 (which is cloned when &s1 is
2916 cloned, since it is a state sub) closes over &s2 and expects
2917 to see it in its outer CV’s pad. If the introcv op clones &s1,
2918 then &s2 is still marked stale. Since &s1 is not active, and
2919 &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
2920 ble will not stay shared’ warning. Because it is the same stub
2921 that will be used when the introcv op for &s2 is executed, clos-
2922 ing over it is safe. Hence, we have to turn off the stale flag
2923 on all lexical subs in the block before we clone any of them.
2924 Hence, having introcv clone the sub cannot work. So we create a
2925 list of ops like this:
2926
2927 lineseq
2928 |
2929 +-- introcv
2930 |
2931 +-- introcv
2932 |
2933 +-- introcv
2934 |
2935 .
2936 .
2937 .
2938 |
2939 +-- clonecv
2940 |
2941 +-- clonecv
2942 |
2943 +-- clonecv
2944 |
2945 .
2946 .
2947 .
2948 */
2949 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
2950 OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
2951 for (;; kid = kid->op_sibling) {
2952 OP *newkid = newOP(OP_CLONECV, 0);
2953 newkid->op_targ = kid->op_targ;
2954 o = op_append_elem(OP_LINESEQ, o, newkid);
2955 if (kid == last) break;
2956 }
2957 retval = op_prepend_elem(OP_LINESEQ, o, retval);
2958 }
1930840b 2959
a88d97bf 2960 CALL_BLOCK_HOOKS(bhk_post_end, &retval);
1930840b 2961
a0d0e21e
LW		 2962 return retval;
2963}
2964
fd85fad2
BM		 2965/*
2966=head1 Compile-time scope hooks
2967
3e4ddde5 2968=for apidoc Aox||blockhook_register
fd85fad2
BM		 2969
2970Register a set of hooks to be called when the Perl lexical scope changes
2971at compile time. See L<perlguts/"Compile-time scope hooks">.
2972
2973=cut
2974*/
2975
bb6c22e7
BM		 2976void
2977Perl_blockhook_register(pTHX_ BHK *hk)
2978{
2979 PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
2980
2981 Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
2982}
2983
76e3520e 2984STATIC OP *
cea2e8a9 2985S_newDEFSVOP(pTHX)
54b9620d 2986{
97aff369 2987 dVAR;
cc76b5cc 2988 const PADOFFSET offset = pad_findmy_pvs("$_", 0);
00b1698f 2989 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
59f00321
RGS		 2990 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2991 }
2992 else {
551405c4 2993 OP * const o = newOP(OP_PADSV, 0);
59f00321
RGS		 2994 o->op_targ = offset;
2995 return o;
2996 }
54b9620d
MB		 2997}
2998
a0d0e21e 2999void
864dbfa3 3000Perl_newPROG(pTHX_ OP *o)
a0d0e21e 3001{
97aff369 3002 dVAR;
7918f24d
NC		 3003
3004 PERL_ARGS_ASSERT_NEWPROG;
3005
3280af22 3006 if (PL_in_eval) {
86a64801 3007 PERL_CONTEXT *cx;
63429d50 3008 I32 i;
b295d113
TH		 3009 if (PL_eval_root)
3010 return;
faef0170
HS		 3011 PL_eval_root = newUNOP(OP_LEAVEEVAL,
3012 ((PL_in_eval & EVAL_KEEPERR)
3013 ? OPf_SPECIAL : 0), o);
86a64801
GG		 3014
3015 cx = &cxstack[cxstack_ix];
3016 assert(CxTYPE(cx) == CXt_EVAL);
3017
3018 if ((cx->blk_gimme & G_WANT) == G_VOID)
3019 scalarvoid(PL_eval_root);
3020 else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3021 list(PL_eval_root);
3022 else
3023 scalar(PL_eval_root);
3024
5983a79d 3025 PL_eval_start = op_linklist(PL_eval_root);
7934575e
GS		 3026 PL_eval_root->op_private |= OPpREFCOUNTED;
3027 OpREFCNT_set(PL_eval_root, 1);
3280af22 3028 PL_eval_root->op_next = 0;
63429d50
FC		 3029 i = PL_savestack_ix;
3030 SAVEFREEOP(o);
3031 ENTER;
a2efc822 3032 CALL_PEEP(PL_eval_start);
86a64801 3033 finalize_optree(PL_eval_root);
63429d50
FC		 3034 LEAVE;
3035 PL_savestack_ix = i;
a0d0e21e
LW		 3036 }
3037 else {
6be89cf9 3038 if (o->op_type == OP_STUB) {
22e660b4
NC		 3039 /* This block is entered if nothing is compiled for the main
3040 program. This will be the case for an genuinely empty main
3041 program, or one which only has BEGIN blocks etc, so already
3042 run and freed.
3043
3044 Historically (5.000) the guard above was !o. However, commit
3045 f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3046 c71fccf11fde0068, changed perly.y so that newPROG() is now
3047 called with the output of block_end(), which returns a new
3048 OP_STUB for the case of an empty optree. ByteLoader (and
3049 maybe other things) also take this path, because they set up
3050 PL_main_start and PL_main_root directly, without generating an
3051 optree.
8b31d4e4
NC		 3052
3053 If the parsing the main program aborts (due to parse errors,
3054 or due to BEGIN or similar calling exit), then newPROG()
3055 isn't even called, and hence this code path and its cleanups
3056 are skipped. This shouldn't make a make a difference:
3057 * a non-zero return from perl_parse is a failure, and
3058 perl_destruct() should be called immediately.
3059 * however, if exit(0) is called during the parse, then
3060 perl_parse() returns 0, and perl_run() is called. As
3061 PL_main_start will be NULL, perl_run() will return
3062 promptly, and the exit code will remain 0.
22e660b4
NC		 3063 */
3064
6be89cf9
AE		 3065 PL_comppad_name = 0;
3066 PL_compcv = 0;
d2c837a0 3067 S_op_destroy(aTHX_ o);
a0d0e21e 3068 return;
6be89cf9 3069 }
3ad73efd 3070 PL_main_root = op_scope(sawparens(scalarvoid(o)));
3280af22
NIS		 3071 PL_curcop = &PL_compiling;
3072 PL_main_start = LINKLIST(PL_main_root);
7934575e
GS		 3073 PL_main_root->op_private |= OPpREFCOUNTED;
3074 OpREFCNT_set(PL_main_root, 1);
3280af22 3075 PL_main_root->op_next = 0;
a2efc822 3076 CALL_PEEP(PL_main_start);
d164302a 3077 finalize_optree(PL_main_root);
8be227ab 3078 cv_forget_slab(PL_compcv);
3280af22 3079 PL_compcv = 0;
3841441e 3080
4fdae800 3081 /* Register with debugger */
84902520 3082 if (PERLDB_INTER) {
b96d8cd9 3083 CV * const cv = get_cvs("DB::postponed", 0);
3841441e
CS		 3084 if (cv) {
3085 dSP;
924508f0 3086 PUSHMARK(SP);
ad64d0ec 3087 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3841441e 3088 PUTBACK;
ad64d0ec 3089 call_sv(MUTABLE_SV(cv), G_DISCARD);
3841441e
CS		 3090 }
3091 }
79072805 3092 }
79072805
LW		 3093}
3094
3095OP *
864dbfa3 3096Perl_localize(pTHX_ OP *o, I32 lex)
79072805 3097{
97aff369 3098 dVAR;
7918f24d
NC		 3099
3100 PERL_ARGS_ASSERT_LOCALIZE;
3101
79072805 3102 if (o->op_flags & OPf_PARENS)
d2be0de5
YST		 3103/* [perl #17376]: this appears to be premature, and results in code such as
3104 C< our(%x); > executing in list mode rather than void mode */
3105#if 0
79072805 3106 list(o);
d2be0de5 3107#else
6f207bd3 3108 NOOP;
d2be0de5 3109#endif
8990e307 3110 else {
f06b5848
DM		 3111 if ( PL_parser->bufptr > PL_parser->oldbufptr
3112 && PL_parser->bufptr[-1] == ','
041457d9 3113 && ckWARN(WARN_PARENTHESIS))
64420d0d 3114 {
f06b5848 3115 char *s = PL_parser->bufptr;
bac662ee 3116 bool sigil = FALSE;
64420d0d 3117
8473848f 3118 /* some heuristics to detect a potential error */
bac662ee 3119 while (*s && (strchr(", \t\n", *s)))
64420d0d 3120 s++;
8473848f 3121
bac662ee
TS		 3122 while (1) {
3123 if (*s && strchr("@$%*", *s) && *++s
0eb30aeb 3124 && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
bac662ee
TS		 3125 s++;
3126 sigil = TRUE;
0eb30aeb 3127 while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
bac662ee
TS		 3128 s++;
3129 while (*s && (strchr(", \t\n", *s)))
3130 s++;
3131 }
3132 else
3133 break;
3134 }
3135 if (sigil && (*s == ';' || *s == '=')) {
3136 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
8473848f 3137 "Parentheses missing around \"%s\" list",
12bd6ede
DM		 3138 lex
3139 ? (PL_parser->in_my == KEY_our
3140 ? "our"
3141 : PL_parser->in_my == KEY_state
3142 ? "state"
3143 : "my")
3144 : "local");
8473848f 3145 }
8990e307
LW		 3146 }
3147 }
93a17b20 3148 if (lex)
eb64745e 3149 o = my(o);
93a17b20 3150 else
3ad73efd 3151 o = op_lvalue(o, OP_NULL); /* a bit kludgey */
12bd6ede
DM		 3152 PL_parser->in_my = FALSE;
3153 PL_parser->in_my_stash = NULL;
eb64745e 3154 return o;
79072805
LW		 3155}
3156
3157OP *
864dbfa3 3158Perl_jmaybe(pTHX_ OP *o)
79072805 3159{
7918f24d
NC		 3160 PERL_ARGS_ASSERT_JMAYBE;
3161
79072805 3162 if (o->op_type == OP_LIST) {
fafc274c 3163 OP * const o2
d4c19fe8 3164 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2fcb4757 3165 o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
79072805
LW		 3166 }
3167 return o;
3168}
3169
985b9e54
GG		 3170PERL_STATIC_INLINE OP *
3171S_op_std_init(pTHX_ OP *o)
3172{
3173 I32 type = o->op_type;
3174
3175 PERL_ARGS_ASSERT_OP_STD_INIT;
3176
3177 if (PL_opargs[type] & OA_RETSCALAR)
3178 scalar(o);
3179 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3180 o->op_targ = pad_alloc(type, SVs_PADTMP);
3181
3182 return o;
3183}
3184
3185PERL_STATIC_INLINE OP *
3186S_op_integerize(pTHX_ OP *o)
3187{
3188 I32 type = o->op_type;
3189
3190 PERL_ARGS_ASSERT_OP_INTEGERIZE;
3191
077da62f
FC		 3192 /* integerize op. */
3193 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
985b9e54 3194 {
f5f19483 3195 dVAR;
985b9e54
GG		 3196 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
3197 }
3198
3199 if (type == OP_NEGATE)
3200 /* XXX might want a ck_negate() for this */
3201 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3202
3203 return o;
3204}
3205
1f676739 3206static OP *
5aaab254 3207S_fold_constants(pTHX_ OP *o)
79072805 3208{
27da23d5 3209 dVAR;
eb578fdb 3210 OP * VOL curop;
eb8433b7 3211 OP *newop;
8ea43dc8 3212 VOL I32 type = o->op_type;
e3cbe32f 3213 SV * VOL sv = NULL;
b7f7fd0b
NC		 3214 int ret = 0;
3215 I32 oldscope;
3216 OP *old_next;
5f2d9966
DM		 3217 SV * const oldwarnhook = PL_warnhook;
3218 SV * const olddiehook = PL_diehook;
c427f4d2 3219 COP not_compiling;
b7f7fd0b 3220 dJMPENV;
79072805 3221
7918f24d
NC		 3222 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3223
22c35a8c 3224 if (!(PL_opargs[type] & OA_FOLDCONST))
79072805
LW		 3225 goto nope;
3226
de939608 3227 switch (type) {
de939608
CS		 3228 case OP_UCFIRST:
3229 case OP_LCFIRST:
3230 case OP_UC:
3231 case OP_LC:
7ccde120 3232 case OP_FC:
69dcf70c
MB		 3233 case OP_SLT:
3234 case OP_SGT:
3235 case OP_SLE:
3236 case OP_SGE:
3237 case OP_SCMP:
b3fd6149 3238 case OP_SPRINTF:
2de3dbcc 3239 /* XXX what about the numeric ops? */
82ad65bb 3240 if (IN_LOCALE_COMPILETIME)
de939608 3241 goto nope;
553e7bb0 3242 break;
dd9a6ccf
FC		 3243 case OP_PACK:
3244 if (!cLISTOPo->op_first->op_sibling
3245 || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3246 goto nope;
3247 {
3248 SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3249 if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3250 {
3251 const char *s = SvPVX_const(sv);
3252 while (s < SvEND(sv)) {
3253 if (*s == 'p' || *s == 'P') goto nope;
3254 s++;
3255 }
3256 }
3257 }
3258 break;
baed7faa
FC		 3259 case OP_REPEAT:
3260 if (o->op_private & OPpREPEAT_DOLIST) goto nope;
de939608
CS		 3261 }
3262
13765c85 3263 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3264 goto nope; /* Don't try to run w/ errors */
3265
79072805 3266 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1496a290
AL		 3267 const OPCODE type = curop->op_type;
3268 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3269 type != OP_LIST &&
3270 type != OP_SCALAR &&
3271 type != OP_NULL &&
3272 type != OP_PUSHMARK)
7a52d87a 3273 {
79072805
LW		 3274 goto nope;
3275 }
3276 }
3277
3278 curop = LINKLIST(o);
b7f7fd0b 3279 old_next = o->op_next;
79072805 3280 o->op_next = 0;
533c011a 3281 PL_op = curop;
b7f7fd0b
NC		 3282
3283 oldscope = PL_scopestack_ix;
edb2152a 3284 create_eval_scope(G_FAKINGEVAL);
b7f7fd0b 3285
c427f4d2
NC		 3286 /* Verify that we don't need to save it: */
3287 assert(PL_curcop == &PL_compiling);
3288 StructCopy(&PL_compiling, &not_compiling, COP);
3289 PL_curcop = &not_compiling;
3290 /* The above ensures that we run with all the correct hints of the
3291 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3292 assert(IN_PERL_RUNTIME);
5f2d9966
DM		 3293 PL_warnhook = PERL_WARNHOOK_FATAL;
3294 PL_diehook = NULL;
b7f7fd0b
NC		 3295 JMPENV_PUSH(ret);
3296
3297 switch (ret) {
3298 case 0:
3299 CALLRUNOPS(aTHX);
3300 sv = *(PL_stack_sp--);
523a0f0c
NC		 3301 if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
3302#ifdef PERL_MAD
3303 /* Can't simply swipe the SV from the pad, because that relies on
3304 the op being freed "real soon now". Under MAD, this doesn't
3305 happen (see the #ifdef below). */
3306 sv = newSVsv(sv);
3307#else
b7f7fd0b 3308 pad_swipe(o->op_targ, FALSE);
523a0f0c
NC		 3309#endif
3310 }
b7f7fd0b
NC		 3311 else if (SvTEMP(sv)) { /* grab mortal temp? */
3312 SvREFCNT_inc_simple_void(sv);
3313 SvTEMP_off(sv);
3314 }
3315 break;
3316 case 3:
3317 /* Something tried to die. Abandon constant folding. */
3318 /* Pretend the error never happened. */
ab69dbc2 3319 CLEAR_ERRSV();
b7f7fd0b
NC		 3320 o->op_next = old_next;
3321 break;
3322 default:
3323 JMPENV_POP;
5f2d9966
DM		 3324 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
3325 PL_warnhook = oldwarnhook;
3326 PL_diehook = olddiehook;
3327 /* XXX note that this croak may fail as we've already blown away
3328 * the stack - eg any nested evals */
b7f7fd0b
NC		 3329 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3330 }
b7f7fd0b 3331 JMPENV_POP;
5f2d9966
DM		 3332 PL_warnhook = oldwarnhook;
3333 PL_diehook = olddiehook;
c427f4d2 3334 PL_curcop = &PL_compiling;
edb2152a
NC		 3335
3336 if (PL_scopestack_ix > oldscope)
3337 delete_eval_scope();
eb8433b7 3338
b7f7fd0b
NC		 3339 if (ret)
3340 goto nope;
3341
eb8433b7 3342#ifndef PERL_MAD
79072805 3343 op_free(o);
eb8433b7 3344#endif
de5e01c2 3345 assert(sv);
79072805 3346 if (type == OP_RV2GV)
159b6efe 3347 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
eb8433b7 3348 else
cc2ebcd7 3349 newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
eb8433b7
NC		 3350 op_getmad(o,newop,'f');
3351 return newop;
aeea060c 3352
b7f7fd0b 3353 nope:
79072805
LW		 3354 return o;
3355}
3356
1f676739 3357static OP *
5aaab254 3358S_gen_constant_list(pTHX_ OP *o)
79072805 3359{
27da23d5 3360 dVAR;
eb578fdb 3361 OP *curop;
6867be6d 3362 const I32 oldtmps_floor = PL_tmps_floor;
79072805 3363
a0d0e21e 3364 list(o);
13765c85 3365 if (PL_parser && PL_parser->error_count)
a0d0e21e
LW		 3366 return o; /* Don't attempt to run with errors */
3367
533c011a 3368 PL_op = curop = LINKLIST(o);
a0d0e21e 3369 o->op_next = 0;
a2efc822 3370 CALL_PEEP(curop);
897d3989 3371 Perl_pp_pushmark(aTHX);
cea2e8a9 3372 CALLRUNOPS(aTHX);
533c011a 3373 PL_op = curop;
78c72037
NC		 3374 assert (!(curop->op_flags & OPf_SPECIAL));
3375 assert(curop->op_type == OP_RANGE);
897d3989 3376 Perl_pp_anonlist(aTHX);
3280af22 3377 PL_tmps_floor = oldtmps_floor;
79072805
LW		 3378
3379 o->op_type = OP_RV2AV;
22c35a8c 3380 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
fb53bbb2
SG		 3381 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
3382 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
1a0a2ba9 3383 o->op_opt = 0; /* needs to be revisited in rpeep() */
79072805 3384 curop = ((UNOP*)o)->op_first;
b37c2d43 3385 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
eb8433b7
NC		 3386#ifdef PERL_MAD
3387 op_getmad(curop,o,'O');
3388#else
79072805 3389 op_free(curop);
eb8433b7 3390#endif
5983a79d 3391 LINKLIST(o);
79072805
LW		 3392 return list(o);
3393}
3394
3395OP *
864dbfa3 3396Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
79072805 3397{
27da23d5 3398 dVAR;
d67594ff 3399 if (type < 0) type = -type, flags |= OPf_SPECIAL;
11343788 3400 if (!o || o->op_type != OP_LIST)
5f66b61c 3401 o = newLISTOP(OP_LIST, 0, o, NULL);
748a9306 3402 else
5dc0d613 3403 o->op_flags &= ~OPf_WANT;
79072805 3404
22c35a8c 3405 if (!(PL_opargs[type] & OA_MARK))
93c66552 3406 op_null(cLISTOPo->op_first);
bf0571fd
FC		 3407 else {
3408 OP * const kid2 = cLISTOPo->op_first->op_sibling;
3409 if (kid2 && kid2->op_type == OP_COREARGS) {
3410 op_null(cLISTOPo->op_first);
3411 kid2->op_private |= OPpCOREARGS_PUSHMARK;
3412 }
3413 }
8990e307 3414
eb160463 3415 o->op_type = (OPCODE)type;
22c35a8c 3416 o->op_ppaddr = PL_ppaddr[type];
11343788 3417 o->op_flags |= flags;
79072805 3418
11343788 3419 o = CHECKOP(type, o);
fe2774ed 3420 if (o->op_type != (unsigned)type)
11343788 3421 return o;
79072805 3422
985b9e54 3423 return fold_constants(op_integerize(op_std_init(o)));
79072805
LW		 3424}
3425
2fcb4757
Z		 3426/*
3427=head1 Optree Manipulation Functions
3428*/
3429
79072805
LW		 3430/* List constructors */
3431
2fcb4757
Z		 3432/*
3433=for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3434
3435Append an item to the list of ops contained directly within a list-type
3436op, returning the lengthened list. I<first> is the list-type op,
3437and I<last> is the op to append to the list. I<optype> specifies the
3438intended opcode for the list. If I<first> is not already a list of the
3439right type, it will be upgraded into one. If either I<first> or I<last>
3440is null, the other is returned unchanged.
3441
3442=cut
3443*/
3444
79072805 3445OP *
2fcb4757 3446Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3447{
3448 if (!first)
3449 return last;
8990e307
LW		 3450
3451 if (!last)
79072805 3452 return first;
8990e307 3453
fe2774ed 3454 if (first->op_type != (unsigned)type
155aba94
GS		 3455 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3456 {
3457 return newLISTOP(type, 0, first, last);
3458 }
79072805 3459
a0d0e21e
LW		 3460 if (first->op_flags & OPf_KIDS)
3461 ((LISTOP*)first)->op_last->op_sibling = last;
3462 else {
3463 first->op_flags |= OPf_KIDS;
3464 ((LISTOP*)first)->op_first = last;
3465 }
3466 ((LISTOP*)first)->op_last = last;
a0d0e21e 3467 return first;
79072805
LW		 3468}
3469
2fcb4757
Z		 3470/*
3471=for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3472
3473Concatenate the lists of ops contained directly within two list-type ops,
3474returning the combined list. I<first> and I<last> are the list-type ops
3475to concatenate. I<optype> specifies the intended opcode for the list.
3476If either I<first> or I<last> is not already a list of the right type,
3477it will be upgraded into one. If either I<first> or I<last> is null,
3478the other is returned unchanged.
3479
3480=cut
3481*/
3482
79072805 3483OP *
2fcb4757 3484Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3485{
3486 if (!first)
2fcb4757 3487 return last;
8990e307
LW		 3488
3489 if (!last)
2fcb4757 3490 return first;
8990e307 3491
fe2774ed 3492 if (first->op_type != (unsigned)type)
2fcb4757 3493 return op_prepend_elem(type, first, last);
8990e307 3494
fe2774ed 3495 if (last->op_type != (unsigned)type)
2fcb4757 3496 return op_append_elem(type, first, last);
79072805 3497
2fcb4757
Z		 3498 ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3499 ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
117dada2 3500 first->op_flags |= (last->op_flags & OPf_KIDS);
1c846c1f 3501
eb8433b7 3502#ifdef PERL_MAD
2fcb4757
Z		 3503 if (((LISTOP*)last)->op_first && first->op_madprop) {
3504 MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
eb8433b7
NC		 3505 if (mp) {
3506 while (mp->mad_next)
3507 mp = mp->mad_next;
3508 mp->mad_next = first->op_madprop;
3509 }
3510 else {
2fcb4757 3511 ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
eb8433b7
NC		 3512 }
3513 }
3514 first->op_madprop = last->op_madprop;
3515 last->op_madprop = 0;
3516#endif
3517
2fcb4757 3518 S_op_destroy(aTHX_ last);
238a4c30 3519
2fcb4757 3520 return first;
79072805
LW		 3521}
3522
2fcb4757
Z		 3523/*
3524=for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3525
3526Prepend an item to the list of ops contained directly within a list-type
3527op, returning the lengthened list. I<first> is the op to prepend to the
3528list, and I<last> is the list-type op. I<optype> specifies the intended
3529opcode for the list. If I<last> is not already a list of the right type,
3530it will be upgraded into one. If either I<first> or I<last> is null,
3531the other is returned unchanged.
3532
3533=cut
3534*/
3535
79072805 3536OP *
2fcb4757 3537Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
79072805
LW		 3538{
3539 if (!first)
3540 return last;
8990e307
LW		 3541
3542 if (!last)
79072805 3543 return first;
8990e307 3544
fe2774ed 3545 if (last->op_type == (unsigned)type) {
8990e307
LW		 3546 if (type == OP_LIST) { /* already a PUSHMARK there */
3547 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3548 ((LISTOP*)last)->op_first->op_sibling = first;
36a5d4ba
DC		 3549 if (!(first->op_flags & OPf_PARENS))
3550 last->op_flags &= ~OPf_PARENS;
8990e307
LW		 3551 }
3552 else {
3553 if (!(last->op_flags & OPf_KIDS)) {
3554 ((LISTOP*)last)->op_last = first;
3555 last->op_flags |= OPf_KIDS;
3556 }
3557 first->op_sibling = ((LISTOP*)last)->op_first;
3558 ((LISTOP*)last)->op_first = first;
79072805 3559 }
117dada2 3560 last->op_flags |= OPf_KIDS;
79072805
LW		 3561 return last;
3562 }
3563
3564 return newLISTOP(type, 0, first, last);
3565}
3566
3567/* Constructors */
3568
eb8433b7
NC		 3569#ifdef PERL_MAD
3570
3571TOKEN *
3572Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3573{
3574 TOKEN *tk;
99129197 3575 Newxz(tk, 1, TOKEN);
eb8433b7
NC		 3576 tk->tk_type = (OPCODE)optype;
3577 tk->tk_type = 12345;
3578 tk->tk_lval = lval;
3579 tk->tk_mad = madprop;
3580 return tk;
3581}
3582
3583void
3584Perl_token_free(pTHX_ TOKEN* tk)
3585{
7918f24d
NC		 3586 PERL_ARGS_ASSERT_TOKEN_FREE;
3587
eb8433b7
NC		 3588 if (tk->tk_type != 12345)
3589 return;
3590 mad_free(tk->tk_mad);
3591 Safefree(tk);
3592}
3593
3594void
3595Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3596{
3597 MADPROP* mp;
3598 MADPROP* tm;
7918f24d
NC		 3599
3600 PERL_ARGS_ASSERT_TOKEN_GETMAD;
3601
eb8433b7
NC		 3602 if (tk->tk_type != 12345) {
3603 Perl_warner(aTHX_ packWARN(WARN_MISC),
3604 "Invalid TOKEN object ignored");
3605 return;
3606 }
3607 tm = tk->tk_mad;
3608 if (!tm)
3609 return;
3610
3611 /* faked up qw list? */
3612 if (slot == '(' &&
3613 tm->mad_type == MAD_SV &&
d503a9ba 3614 SvPVX((SV *)tm->mad_val)[0] == 'q')
eb8433b7
NC		 3615 slot = 'x';
3616
3617 if (o) {
3618 mp = o->op_madprop;
3619 if (mp) {
3620 for (;;) {
3621 /* pretend constant fold didn't happen? */
3622 if (mp->mad_key == 'f' &&
3623 (o->op_type == OP_CONST ||
3624 o->op_type == OP_GV) )
3625 {
3626 token_getmad(tk,(OP*)mp->mad_val,slot);
3627 return;
3628 }
3629 if (!mp->mad_next)
3630 break;
3631 mp = mp->mad_next;
3632 }
3633 mp->mad_next = tm;
3634 mp = mp->mad_next;
3635 }
3636 else {
3637 o->op_madprop = tm;
3638 mp = o->op_madprop;
3639 }
3640 if (mp->mad_key == 'X')
3641 mp->mad_key = slot; /* just change the first one */
3642
3643 tk->tk_mad = 0;
3644 }
3645 else
3646 mad_free(tm);
3647 Safefree(tk);
3648}