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