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