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