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