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