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