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