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