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