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