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