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